source: trunk/third/perl/regcomp.c @ 20075

Revision 20075, 142.9 KB checked in by zacheiss, 21 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r20074, which included commits to RCS files with non-trunk default branches.
Line 
1/*    regcomp.c
2 */
3
4/*
5 * "A fair jaw-cracker dwarf-language must be."  --Samwise Gamgee
6 */
7
8/* NOTE: this is derived from Henry Spencer's regexp code, and should not
9 * confused with the original package (see point 3 below).  Thanks, Henry!
10 */
11
12/* Additional note: this code is very heavily munged from Henry's version
13 * in places.  In some spots I've traded clarity for efficiency, so don't
14 * blame Henry for some of the lack of readability.
15 */
16
17/* The names of the functions have been changed from regcomp and
18 * regexec to  pregcomp and pregexec in order to avoid conflicts
19 * with the POSIX routines of the same names.
20*/
21
22#ifdef PERL_EXT_RE_BUILD
23/* need to replace pregcomp et al, so enable that */
24#  ifndef PERL_IN_XSUB_RE
25#    define PERL_IN_XSUB_RE
26#  endif
27/* need access to debugger hooks */
28#  if defined(PERL_EXT_RE_DEBUG) && !defined(DEBUGGING)
29#    define DEBUGGING
30#  endif
31#endif
32
33#ifdef PERL_IN_XSUB_RE
34/* We *really* need to overwrite these symbols: */
35#  define Perl_pregcomp my_regcomp
36#  define Perl_regdump my_regdump
37#  define Perl_regprop my_regprop
38#  define Perl_pregfree my_regfree
39#  define Perl_re_intuit_string my_re_intuit_string
40/* *These* symbols are masked to allow static link. */
41#  define Perl_regnext my_regnext
42#  define Perl_save_re_context my_save_re_context
43#  define Perl_reginitcolors my_reginitcolors
44
45#  define PERL_NO_GET_CONTEXT
46#endif
47
48/*SUPPRESS 112*/
49/*
50 * pregcomp and pregexec -- regsub and regerror are not used in perl
51 *
52 *      Copyright (c) 1986 by University of Toronto.
53 *      Written by Henry Spencer.  Not derived from licensed software.
54 *
55 *      Permission is granted to anyone to use this software for any
56 *      purpose on any computer system, and to redistribute it freely,
57 *      subject to the following restrictions:
58 *
59 *      1. The author is not responsible for the consequences of use of
60 *              this software, no matter how awful, even if they arise
61 *              from defects in it.
62 *
63 *      2. The origin of this software must not be misrepresented, either
64 *              by explicit claim or by omission.
65 *
66 *      3. Altered versions must be plainly marked as such, and must not
67 *              be misrepresented as being the original software.
68 *
69 *
70 ****    Alterations to Henry's code are...
71 ****
72 ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
73 ****    2000, 2001, 2002, 2003, by Larry Wall and others
74 ****
75 ****    You may distribute under the terms of either the GNU General Public
76 ****    License or the Artistic License, as specified in the README file.
77
78 *
79 * Beware that some of this code is subtly aware of the way operator
80 * precedence is structured in regular expressions.  Serious changes in
81 * regular-expression syntax might require a total rethink.
82 */
83#include "EXTERN.h"
84#define PERL_IN_REGCOMP_C
85#include "perl.h"
86
87#ifndef PERL_IN_XSUB_RE
88#  include "INTERN.h"
89#endif
90
91#define REG_COMP_C
92#include "regcomp.h"
93
94#ifdef op
95#undef op
96#endif /* op */
97
98#ifdef MSDOS
99#  if defined(BUGGY_MSC6)
100 /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
101#    pragma optimize("a",off)
102 /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
103#    pragma optimize("w",on )
104#  endif /* BUGGY_MSC6 */
105#endif /* MSDOS */
106
107#ifndef STATIC
108#define STATIC  static
109#endif
110
111typedef struct RExC_state_t {
112    U32         flags;                  /* are we folding, multilining? */
113    char        *precomp;               /* uncompiled string. */
114    regexp      *rx;
115    char        *start;                 /* Start of input for compile */
116    char        *end;                   /* End of input for compile */
117    char        *parse;                 /* Input-scan pointer. */
118    I32         whilem_seen;            /* number of WHILEM in this expr */
119    regnode     *emit_start;            /* Start of emitted-code area */
120    regnode     *emit;                  /* Code-emit pointer; &regdummy = don't = compiling */
121    I32         naughty;                /* How bad is this pattern? */
122    I32         sawback;                /* Did we see \1, ...? */
123    U32         seen;
124    I32         size;                   /* Code size. */
125    I32         npar;                   /* () count. */
126    I32         extralen;
127    I32         seen_zerolen;
128    I32         seen_evals;
129    I32         utf8;
130#if ADD_TO_REGEXEC
131    char        *starttry;              /* -Dr: where regtry was called. */
132#define RExC_starttry   (pRExC_state->starttry)
133#endif
134} RExC_state_t;
135
136#define RExC_flags      (pRExC_state->flags)
137#define RExC_precomp    (pRExC_state->precomp)
138#define RExC_rx         (pRExC_state->rx)
139#define RExC_start      (pRExC_state->start)
140#define RExC_end        (pRExC_state->end)
141#define RExC_parse      (pRExC_state->parse)
142#define RExC_whilem_seen        (pRExC_state->whilem_seen)
143#define RExC_offsets    (pRExC_state->rx->offsets) /* I am not like the others */
144#define RExC_emit       (pRExC_state->emit)
145#define RExC_emit_start (pRExC_state->emit_start)
146#define RExC_naughty    (pRExC_state->naughty)
147#define RExC_sawback    (pRExC_state->sawback)
148#define RExC_seen       (pRExC_state->seen)
149#define RExC_size       (pRExC_state->size)
150#define RExC_npar       (pRExC_state->npar)
151#define RExC_extralen   (pRExC_state->extralen)
152#define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
153#define RExC_seen_evals (pRExC_state->seen_evals)
154#define RExC_utf8       (pRExC_state->utf8)
155
156#define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
157#define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
158        ((*s) == '{' && regcurly(s)))
159
160#ifdef SPSTART
161#undef SPSTART          /* dratted cpp namespace... */
162#endif
163/*
164 * Flags to be passed up and down.
165 */
166#define WORST           0       /* Worst case. */
167#define HASWIDTH        0x1     /* Known to match non-null strings. */
168#define SIMPLE          0x2     /* Simple enough to be STAR/PLUS operand. */
169#define SPSTART         0x4     /* Starts with * or +. */
170#define TRYAGAIN        0x8     /* Weeded out a declaration. */
171
172/* Length of a variant. */
173
174typedef struct scan_data_t {
175    I32 len_min;
176    I32 len_delta;
177    I32 pos_min;
178    I32 pos_delta;
179    SV *last_found;
180    I32 last_end;                       /* min value, <0 unless valid. */
181    I32 last_start_min;
182    I32 last_start_max;
183    SV **longest;                       /* Either &l_fixed, or &l_float. */
184    SV *longest_fixed;
185    I32 offset_fixed;
186    SV *longest_float;
187    I32 offset_float_min;
188    I32 offset_float_max;
189    I32 flags;
190    I32 whilem_c;
191    I32 *last_closep;
192    struct regnode_charclass_class *start_class;
193} scan_data_t;
194
195/*
196 * Forward declarations for pregcomp()'s friends.
197 */
198
199static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
200                                      0, 0, 0, 0, 0, 0};
201
202#define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
203#define SF_BEFORE_SEOL          0x1
204#define SF_BEFORE_MEOL          0x2
205#define SF_FIX_BEFORE_EOL       (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
206#define SF_FL_BEFORE_EOL        (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
207
208#ifdef NO_UNARY_PLUS
209#  define SF_FIX_SHIFT_EOL      (0+2)
210#  define SF_FL_SHIFT_EOL               (0+4)
211#else
212#  define SF_FIX_SHIFT_EOL      (+2)
213#  define SF_FL_SHIFT_EOL               (+4)
214#endif
215
216#define SF_FIX_BEFORE_SEOL      (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
217#define SF_FIX_BEFORE_MEOL      (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
218
219#define SF_FL_BEFORE_SEOL       (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
220#define SF_FL_BEFORE_MEOL       (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
221#define SF_IS_INF               0x40
222#define SF_HAS_PAR              0x80
223#define SF_IN_PAR               0x100
224#define SF_HAS_EVAL             0x200
225#define SCF_DO_SUBSTR           0x400
226#define SCF_DO_STCLASS_AND      0x0800
227#define SCF_DO_STCLASS_OR       0x1000
228#define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
229#define SCF_WHILEM_VISITED_POS  0x2000
230
231#define UTF (RExC_utf8 != 0)
232#define LOC ((RExC_flags & PMf_LOCALE) != 0)
233#define FOLD ((RExC_flags & PMf_FOLD) != 0)
234
235#define OOB_UNICODE             12345678
236#define OOB_NAMEDCLASS          -1
237
238#define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
239#define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
240
241
242/* length of regex to show in messages that don't mark a position within */
243#define RegexLengthToShowInErrorMessages 127
244
245/*
246 * If MARKER[12] are adjusted, be sure to adjust the constants at the top
247 * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
248 * op/pragma/warn/regcomp.
249 */
250#define MARKER1 "<-- HERE"    /* marker as it appears in the description */
251#define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
252
253#define REPORT_LOCATION " in regex; marked by " MARKER1 " in m/%.*s" MARKER2 "%s/"
254
255/*
256 * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
257 * arg. Show regex, up to a maximum length. If it's too long, chop and add
258 * "...".
259 */
260#define FAIL(msg) STMT_START {                                          \
261    char *ellipses = "";                                                \
262    IV len = RExC_end - RExC_precomp;                                   \
263                                                                        \
264    if (!SIZE_ONLY)                                                     \
265        SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx);                      \
266    if (len > RegexLengthToShowInErrorMessages) {                       \
267        /* chop 10 shorter than the max, to ensure meaning of "..." */  \
268        len = RegexLengthToShowInErrorMessages - 10;                    \
269        ellipses = "...";                                               \
270    }                                                                   \
271    Perl_croak(aTHX_ "%s in regex m/%.*s%s/",                           \
272            msg, (int)len, RExC_precomp, ellipses);                     \
273} STMT_END
274
275/*
276 * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
277 * args. Show regex, up to a maximum length. If it's too long, chop and add
278 * "...".
279 */
280#define FAIL2(pat,msg) STMT_START {                                     \
281    char *ellipses = "";                                                \
282    IV len = RExC_end - RExC_precomp;                                   \
283                                                                        \
284    if (!SIZE_ONLY)                                                     \
285        SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx);                      \
286    if (len > RegexLengthToShowInErrorMessages) {                       \
287        /* chop 10 shorter than the max, to ensure meaning of "..." */  \
288        len = RegexLengthToShowInErrorMessages - 10;                    \
289        ellipses = "...";                                               \
290    }                                                                   \
291    S_re_croak2(aTHX_ pat, " in regex m/%.*s%s/",                       \
292            msg, (int)len, RExC_precomp, ellipses);                     \
293} STMT_END
294
295
296/*
297 * Simple_vFAIL -- like FAIL, but marks the current location in the scan
298 */
299#define Simple_vFAIL(m) STMT_START {                                    \
300    IV offset = RExC_parse - RExC_precomp;                              \
301    Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
302            m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
303} STMT_END
304
305/*
306 * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
307 */
308#define vFAIL(m) STMT_START {                           \
309    if (!SIZE_ONLY)                                     \
310        SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx);      \
311    Simple_vFAIL(m);                                    \
312} STMT_END
313
314/*
315 * Like Simple_vFAIL(), but accepts two arguments.
316 */
317#define Simple_vFAIL2(m,a1) STMT_START {                        \
318    IV offset = RExC_parse - RExC_precomp;                      \
319    S_re_croak2(aTHX_ m, REPORT_LOCATION, a1,                   \
320            (int)offset, RExC_precomp, RExC_precomp + offset);  \
321} STMT_END
322
323/*
324 * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
325 */
326#define vFAIL2(m,a1) STMT_START {                       \
327    if (!SIZE_ONLY)                                     \
328        SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx);      \
329    Simple_vFAIL2(m, a1);                               \
330} STMT_END
331
332
333/*
334 * Like Simple_vFAIL(), but accepts three arguments.
335 */
336#define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
337    IV offset = RExC_parse - RExC_precomp;                      \
338    S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2,               \
339            (int)offset, RExC_precomp, RExC_precomp + offset);  \
340} STMT_END
341
342/*
343 * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
344 */
345#define vFAIL3(m,a1,a2) STMT_START {                    \
346    if (!SIZE_ONLY)                                     \
347        SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx);      \
348    Simple_vFAIL3(m, a1, a2);                           \
349} STMT_END
350
351/*
352 * Like Simple_vFAIL(), but accepts four arguments.
353 */
354#define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
355    IV offset = RExC_parse - RExC_precomp;                      \
356    S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3,           \
357            (int)offset, RExC_precomp, RExC_precomp + offset);  \
358} STMT_END
359
360/*
361 * Like Simple_vFAIL(), but accepts five arguments.
362 */
363#define Simple_vFAIL5(m, a1, a2, a3, a4) STMT_START {           \
364    IV offset = RExC_parse - RExC_precomp;                      \
365    S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3, a4,       \
366            (int)offset, RExC_precomp, RExC_precomp + offset);  \
367} STMT_END
368
369
370#define vWARN(loc,m) STMT_START {                                       \
371    IV offset = loc - RExC_precomp;                                     \
372    Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s" REPORT_LOCATION,      \
373            m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
374} STMT_END
375
376#define vWARNdep(loc,m) STMT_START {                                    \
377    IV offset = loc - RExC_precomp;                                     \
378    Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),          \
379            "%s" REPORT_LOCATION,                                       \
380            m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
381} STMT_END
382
383
384#define vWARN2(loc, m, a1) STMT_START {                                 \
385    IV offset = loc - RExC_precomp;                                     \
386    Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
387            a1, (int)offset, RExC_precomp, RExC_precomp + offset);      \
388} STMT_END
389
390#define vWARN3(loc, m, a1, a2) STMT_START {                             \
391    IV offset = loc - RExC_precomp;                                     \
392    Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
393            a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
394} STMT_END
395
396#define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
397    IV offset = loc - RExC_precomp;                                     \
398    Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
399            a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
400} STMT_END
401
402#define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
403    IV offset = loc - RExC_precomp;                                     \
404    Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
405            a1, a2, a3, a4, (int)offset, RExC_precomp, RExC_precomp + offset); \
406} STMT_END
407
408
409/* Allow for side effects in s */
410#define REGC(c,s) STMT_START {                  \
411    if (!SIZE_ONLY) *(s) = (c); else (void)(s); \
412} STMT_END
413
414/* Macros for recording node offsets.   20001227 mjd@plover.com
415 * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
416 * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
417 * Element 0 holds the number n.
418 */
419
420#define MJD_OFFSET_DEBUG(x)
421/* #define MJD_OFFSET_DEBUG(x) Perl_warn_nocontext x */
422
423
424#define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
425    if (! SIZE_ONLY) {                                                  \
426        MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
427                __LINE__, (node), (byte)));                             \
428        if((node) < 0) {                                                \
429            Perl_croak(aTHX_ "value of node is %d in Offset macro", node); \
430        } else {                                                        \
431            RExC_offsets[2*(node)-1] = (byte);                          \
432        }                                                               \
433    }                                                                   \
434} STMT_END
435
436#define Set_Node_Offset(node,byte) \
437    Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
438#define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
439
440#define Set_Node_Length_To_R(node,len) STMT_START {                     \
441    if (! SIZE_ONLY) {                                                  \
442        MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
443                __LINE__, (node), (len)));                              \
444        if((node) < 0) {                                                \
445            Perl_croak(aTHX_ "value of node is %d in Length macro", node); \
446        } else {                                                        \
447            RExC_offsets[2*(node)] = (len);                             \
448        }                                                               \
449    }                                                                   \
450} STMT_END
451
452#define Set_Node_Length(node,len) \
453    Set_Node_Length_To_R((node)-RExC_emit_start, len)
454#define Set_Cur_Node_Length(len) Set_Node_Length(RExC_emit, len)
455#define Set_Node_Cur_Length(node) \
456    Set_Node_Length(node, RExC_parse - parse_start)
457
458/* Get offsets and lengths */
459#define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
460#define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
461
462static void clear_re(pTHX_ void *r);
463
464/* Mark that we cannot extend a found fixed substring at this point.
465   Updata the longest found anchored substring and the longest found
466   floating substrings if needed. */
467
468STATIC void
469S_scan_commit(pTHX_ RExC_state_t *pRExC_state, scan_data_t *data)
470{
471    STRLEN l = CHR_SVLEN(data->last_found);
472    STRLEN old_l = CHR_SVLEN(*data->longest);
473
474    if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
475        SvSetMagicSV(*data->longest, data->last_found);
476        if (*data->longest == data->longest_fixed) {
477            data->offset_fixed = l ? data->last_start_min : data->pos_min;
478            if (data->flags & SF_BEFORE_EOL)
479                data->flags
480                    |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
481            else
482                data->flags &= ~SF_FIX_BEFORE_EOL;
483        }
484        else {
485            data->offset_float_min = l ? data->last_start_min : data->pos_min;
486            data->offset_float_max = (l
487                                      ? data->last_start_max
488                                      : data->pos_min + data->pos_delta);
489            if ((U32)data->offset_float_max > (U32)I32_MAX)
490                data->offset_float_max = I32_MAX;
491            if (data->flags & SF_BEFORE_EOL)
492                data->flags
493                    |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
494            else
495                data->flags &= ~SF_FL_BEFORE_EOL;
496        }
497    }
498    SvCUR_set(data->last_found, 0);
499    {
500        SV * sv = data->last_found;
501        MAGIC *mg =
502            SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
503        if (mg && mg->mg_len > 0)
504            mg->mg_len = 0;
505    }
506    data->last_end = -1;
507    data->flags &= ~SF_BEFORE_EOL;
508}
509
510/* Can match anything (initialization) */
511STATIC void
512S_cl_anything(pTHX_ RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
513{
514    ANYOF_CLASS_ZERO(cl);
515    ANYOF_BITMAP_SETALL(cl);
516    cl->flags = ANYOF_EOS|ANYOF_UNICODE_ALL;
517    if (LOC)
518        cl->flags |= ANYOF_LOCALE;
519}
520
521/* Can match anything (initialization) */
522STATIC int
523S_cl_is_anything(pTHX_ struct regnode_charclass_class *cl)
524{
525    int value;
526
527    for (value = 0; value <= ANYOF_MAX; value += 2)
528        if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
529            return 1;
530    if (!(cl->flags & ANYOF_UNICODE_ALL))
531        return 0;
532    if (!ANYOF_BITMAP_TESTALLSET(cl))
533        return 0;
534    return 1;
535}
536
537/* Can match anything (initialization) */
538STATIC void
539S_cl_init(pTHX_ RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
540{
541    Zero(cl, 1, struct regnode_charclass_class);
542    cl->type = ANYOF;
543    cl_anything(pRExC_state, cl);
544}
545
546STATIC void
547S_cl_init_zero(pTHX_ RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
548{
549    Zero(cl, 1, struct regnode_charclass_class);
550    cl->type = ANYOF;
551    cl_anything(pRExC_state, cl);
552    if (LOC)
553        cl->flags |= ANYOF_LOCALE;
554}
555
556/* 'And' a given class with another one.  Can create false positives */
557/* We assume that cl is not inverted */
558STATIC void
559S_cl_and(pTHX_ struct regnode_charclass_class *cl,
560         struct regnode_charclass_class *and_with)
561{
562    if (!(and_with->flags & ANYOF_CLASS)
563        && !(cl->flags & ANYOF_CLASS)
564        && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
565        && !(and_with->flags & ANYOF_FOLD)
566        && !(cl->flags & ANYOF_FOLD)) {
567        int i;
568
569        if (and_with->flags & ANYOF_INVERT)
570            for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
571                cl->bitmap[i] &= ~and_with->bitmap[i];
572        else
573            for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
574                cl->bitmap[i] &= and_with->bitmap[i];
575    } /* XXXX: logic is complicated otherwise, leave it along for a moment. */
576    if (!(and_with->flags & ANYOF_EOS))
577        cl->flags &= ~ANYOF_EOS;
578
579    if (cl->flags & ANYOF_UNICODE_ALL && and_with->flags & ANYOF_UNICODE &&
580        !(and_with->flags & ANYOF_INVERT)) {
581        cl->flags &= ~ANYOF_UNICODE_ALL;
582        cl->flags |= ANYOF_UNICODE;
583        ARG_SET(cl, ARG(and_with));
584    }
585    if (!(and_with->flags & ANYOF_UNICODE_ALL) &&
586        !(and_with->flags & ANYOF_INVERT))
587        cl->flags &= ~ANYOF_UNICODE_ALL;
588    if (!(and_with->flags & (ANYOF_UNICODE|ANYOF_UNICODE_ALL)) &&
589        !(and_with->flags & ANYOF_INVERT))
590        cl->flags &= ~ANYOF_UNICODE;
591}
592
593/* 'OR' a given class with another one.  Can create false positives */
594/* We assume that cl is not inverted */
595STATIC void
596S_cl_or(pTHX_ RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, struct regnode_charclass_class *or_with)
597{
598    if (or_with->flags & ANYOF_INVERT) {
599        /* We do not use
600         * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2))
601         *   <= (B1 | !B2) | (CL1 | !CL2)
602         * which is wasteful if CL2 is small, but we ignore CL2:
603         *   (B1 | CL1) | (!B2 & !CL2) <= (B1 | CL1) | !B2 = (B1 | !B2) | CL1
604         * XXXX Can we handle case-fold?  Unclear:
605         *   (OK1(i) | OK1(i')) | !(OK1(i) | OK1(i')) =
606         *   (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i'))
607         */
608        if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
609             && !(or_with->flags & ANYOF_FOLD)
610             && !(cl->flags & ANYOF_FOLD) ) {
611            int i;
612
613            for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
614                cl->bitmap[i] |= ~or_with->bitmap[i];
615        } /* XXXX: logic is complicated otherwise */
616        else {
617            cl_anything(pRExC_state, cl);
618        }
619    } else {
620        /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
621        if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
622             && (!(or_with->flags & ANYOF_FOLD)
623                 || (cl->flags & ANYOF_FOLD)) ) {
624            int i;
625
626            /* OR char bitmap and class bitmap separately */
627            for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
628                cl->bitmap[i] |= or_with->bitmap[i];
629            if (or_with->flags & ANYOF_CLASS) {
630                for (i = 0; i < ANYOF_CLASSBITMAP_SIZE; i++)
631                    cl->classflags[i] |= or_with->classflags[i];
632                cl->flags |= ANYOF_CLASS;
633            }
634        }
635        else { /* XXXX: logic is complicated, leave it along for a moment. */
636            cl_anything(pRExC_state, cl);
637        }
638    }
639    if (or_with->flags & ANYOF_EOS)
640        cl->flags |= ANYOF_EOS;
641
642    if (cl->flags & ANYOF_UNICODE && or_with->flags & ANYOF_UNICODE &&
643        ARG(cl) != ARG(or_with)) {
644        cl->flags |= ANYOF_UNICODE_ALL;
645        cl->flags &= ~ANYOF_UNICODE;
646    }
647    if (or_with->flags & ANYOF_UNICODE_ALL) {
648        cl->flags |= ANYOF_UNICODE_ALL;
649        cl->flags &= ~ANYOF_UNICODE;
650    }
651}
652
653/*
654 * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
655 * These need to be revisited when a newer toolchain becomes available.
656 */
657#if defined(__sparc64__) && defined(__GNUC__)
658#   if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
659#       undef  SPARC64_GCC_WORKAROUND
660#       define SPARC64_GCC_WORKAROUND 1
661#   endif
662#endif
663
664/* REx optimizer.  Converts nodes into quickier variants "in place".
665   Finds fixed substrings.  */
666
667/* Stops at toplevel WHILEM as well as at `last'. At end *scanp is set
668   to the position after last scanned or to NULL. */
669
670STATIC I32
671S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, regnode *last, scan_data_t *data, U32 flags)
672                        /* scanp: Start here (read-write). */
673                        /* deltap: Write maxlen-minlen here. */
674                        /* last: Stop before this one. */
675{
676    I32 min = 0, pars = 0, code;
677    regnode *scan = *scanp, *next;
678    I32 delta = 0;
679    int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
680    int is_inf_internal = 0;            /* The studied chunk is infinite */
681    I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
682    scan_data_t data_fake;
683    struct regnode_charclass_class and_with; /* Valid if flags & SCF_DO_STCLASS_OR */
684
685    while (scan && OP(scan) != END && scan < last) {
686        /* Peephole optimizer: */
687
688        if (PL_regkind[(U8)OP(scan)] == EXACT) {
689            /* Merge several consecutive EXACTish nodes into one. */
690            regnode *n = regnext(scan);
691            U32 stringok = 1;
692#ifdef DEBUGGING
693            regnode *stop = scan;
694#endif
695
696            next = scan + NODE_SZ_STR(scan);
697            /* Skip NOTHING, merge EXACT*. */
698            while (n &&
699                   ( PL_regkind[(U8)OP(n)] == NOTHING ||
700                     (stringok && (OP(n) == OP(scan))))
701                   && NEXT_OFF(n)
702                   && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX) {
703                if (OP(n) == TAIL || n > next)
704                    stringok = 0;
705                if (PL_regkind[(U8)OP(n)] == NOTHING) {
706                    NEXT_OFF(scan) += NEXT_OFF(n);
707                    next = n + NODE_STEP_REGNODE;
708#ifdef DEBUGGING
709                    if (stringok)
710                        stop = n;
711#endif
712                    n = regnext(n);
713                }
714                else if (stringok) {
715                    int oldl = STR_LEN(scan);
716                    regnode *nnext = regnext(n);
717
718                    if (oldl + STR_LEN(n) > U8_MAX)
719                        break;
720                    NEXT_OFF(scan) += NEXT_OFF(n);
721                    STR_LEN(scan) += STR_LEN(n);
722                    next = n + NODE_SZ_STR(n);
723                    /* Now we can overwrite *n : */
724                    Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
725#ifdef DEBUGGING
726                    stop = next - 1;
727#endif
728                    n = nnext;
729                }
730            }
731
732            if (UTF && OP(scan) == EXACTF && STR_LEN(scan) >= 6) {
733/*
734  Two problematic code points in Unicode casefolding of EXACT nodes:
735
736   U+0390 - GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
737   U+03B0 - GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
738
739   which casefold to
740
741   Unicode                      UTF-8
742
743   U+03B9 U+0308 U+0301         0xCE 0xB9 0xCC 0x88 0xCC 0x81
744   U+03C5 U+0308 U+0301         0xCF 0x85 0xCC 0x88 0xCC 0x81
745
746   This means that in case-insensitive matching (or "loose matching",
747   as Unicode calls it), an EXACTF of length six (the UTF-8 encoded byte
748   length of the above casefolded versions) can match a target string
749   of length two (the byte length of UTF-8 encoded U+0390 or U+03B0).
750   This would rather mess up the minimum length computation.
751
752   What we'll do is to look for the tail four bytes, and then peek
753   at the preceding two bytes to see whether we need to decrease
754   the minimum length by four (six minus two).
755
756   Thanks to the design of UTF-8, there cannot be false matches:
757   A sequence of valid UTF-8 bytes cannot be a subsequence of
758   another valid sequence of UTF-8 bytes.
759
760*/
761                 char *s0 = STRING(scan), *s, *t;
762                 char *s1 = s0 + STR_LEN(scan) - 1, *s2 = s1 - 4;
763                 char *t0 = "\xcc\x88\xcc\x81";
764                 char *t1 = t0 + 3;
765                 
766                 for (s = s0 + 2;
767                      s < s2 && (t = ninstr(s, s1, t0, t1));
768                      s = t + 4) {
769                      if (((U8)t[-1] == 0xB9 && (U8)t[-2] == 0xCE) ||
770                          ((U8)t[-1] == 0x85 && (U8)t[-2] == 0xCF))
771                           min -= 4;
772                 }
773            }
774
775#ifdef DEBUGGING
776            /* Allow dumping */
777            n = scan + NODE_SZ_STR(scan);
778            while (n <= stop) {
779                if (PL_regkind[(U8)OP(n)] != NOTHING || OP(n) == NOTHING) {
780                    OP(n) = OPTIMIZED;
781                    NEXT_OFF(n) = 0;
782                }
783                n++;
784            }
785#endif
786        }
787        /* Follow the next-chain of the current node and optimize
788           away all the NOTHINGs from it.  */
789        if (OP(scan) != CURLYX) {
790            int max = (reg_off_by_arg[OP(scan)]
791                       ? I32_MAX
792                       /* I32 may be smaller than U16 on CRAYs! */
793                       : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
794            int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
795            int noff;
796            regnode *n = scan;
797       
798            /* Skip NOTHING and LONGJMP. */
799            while ((n = regnext(n))
800                   && ((PL_regkind[(U8)OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
801                       || ((OP(n) == LONGJMP) && (noff = ARG(n))))
802                   && off + noff < max)
803                off += noff;
804            if (reg_off_by_arg[OP(scan)])
805                ARG(scan) = off;
806            else
807                NEXT_OFF(scan) = off;
808        }
809        /* The principal pseudo-switch.  Cannot be a switch, since we
810           look into several different things.  */
811        if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
812                   || OP(scan) == IFTHEN || OP(scan) == SUSPEND) {
813            next = regnext(scan);
814            code = OP(scan);
815       
816            if (OP(next) == code || code == IFTHEN || code == SUSPEND) {
817                I32 max1 = 0, min1 = I32_MAX, num = 0;
818                struct regnode_charclass_class accum;
819               
820                if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
821                    scan_commit(pRExC_state, data); /* Cannot merge strings after this. */
822                if (flags & SCF_DO_STCLASS)
823                    cl_init_zero(pRExC_state, &accum);
824                while (OP(scan) == code) {
825                    I32 deltanext, minnext, f = 0, fake;
826                    struct regnode_charclass_class this_class;
827
828                    num++;
829                    data_fake.flags = 0;
830                    if (data) {         
831                        data_fake.whilem_c = data->whilem_c;
832                        data_fake.last_closep = data->last_closep;
833                    }
834                    else
835                        data_fake.last_closep = &fake;
836                    next = regnext(scan);
837                    scan = NEXTOPER(scan);
838                    if (code != BRANCH)
839                        scan = NEXTOPER(scan);
840                    if (flags & SCF_DO_STCLASS) {
841                        cl_init(pRExC_state, &this_class);
842                        data_fake.start_class = &this_class;
843                        f = SCF_DO_STCLASS_AND;
844                    }           
845                    if (flags & SCF_WHILEM_VISITED_POS)
846                        f |= SCF_WHILEM_VISITED_POS;
847                    /* we suppose the run is continuous, last=next...*/
848                    minnext = study_chunk(pRExC_state, &scan, &deltanext,
849                                          next, &data_fake, f);
850                    if (min1 > minnext)
851                        min1 = minnext;
852                    if (max1 < minnext + deltanext)
853                        max1 = minnext + deltanext;
854                    if (deltanext == I32_MAX)
855                        is_inf = is_inf_internal = 1;
856                    scan = next;
857                    if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
858                        pars++;
859                    if (data && (data_fake.flags & SF_HAS_EVAL))
860                        data->flags |= SF_HAS_EVAL;
861                    if (data)
862                        data->whilem_c = data_fake.whilem_c;
863                    if (flags & SCF_DO_STCLASS)
864                        cl_or(pRExC_state, &accum, &this_class);
865                    if (code == SUSPEND)
866                        break;
867                }
868                if (code == IFTHEN && num < 2) /* Empty ELSE branch */
869                    min1 = 0;
870                if (flags & SCF_DO_SUBSTR) {
871                    data->pos_min += min1;
872                    data->pos_delta += max1 - min1;
873                    if (max1 != min1 || is_inf)
874                        data->longest = &(data->longest_float);
875                }
876                min += min1;
877                delta += max1 - min1;
878                if (flags & SCF_DO_STCLASS_OR) {
879                    cl_or(pRExC_state, data->start_class, &accum);
880                    if (min1) {
881                        cl_and(data->start_class, &and_with);
882                        flags &= ~SCF_DO_STCLASS;
883                    }
884                }
885                else if (flags & SCF_DO_STCLASS_AND) {
886                    if (min1) {
887                        cl_and(data->start_class, &accum);
888                        flags &= ~SCF_DO_STCLASS;
889                    }
890                    else {
891                        /* Switch to OR mode: cache the old value of
892                         * data->start_class */
893                        StructCopy(data->start_class, &and_with,
894                                   struct regnode_charclass_class);
895                        flags &= ~SCF_DO_STCLASS_AND;
896                        StructCopy(&accum, data->start_class,
897                                   struct regnode_charclass_class);
898                        flags |= SCF_DO_STCLASS_OR;
899                        data->start_class->flags |= ANYOF_EOS;
900                    }
901                }
902            }
903            else if (code == BRANCHJ)   /* single branch is optimized. */
904                scan = NEXTOPER(NEXTOPER(scan));
905            else                        /* single branch is optimized. */
906                scan = NEXTOPER(scan);
907            continue;
908        }
909        else if (OP(scan) == EXACT) {
910            I32 l = STR_LEN(scan);
911            UV uc = *((U8*)STRING(scan));
912            if (UTF) {
913                U8 *s = (U8*)STRING(scan);
914                l = utf8_length(s, s + l);
915                uc = utf8_to_uvchr(s, NULL);
916            }
917            min += l;
918            if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
919                /* The code below prefers earlier match for fixed
920                   offset, later match for variable offset.  */
921                if (data->last_end == -1) { /* Update the start info. */
922                    data->last_start_min = data->pos_min;
923                    data->last_start_max = is_inf
924                        ? I32_MAX : data->pos_min + data->pos_delta;
925                }
926                sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
927                {
928                    SV * sv = data->last_found;
929                    MAGIC *mg = SvUTF8(sv) && SvMAGICAL(sv) ?
930                        mg_find(sv, PERL_MAGIC_utf8) : NULL;
931                    if (mg && mg->mg_len >= 0)
932                        mg->mg_len += utf8_length((U8*)STRING(scan),
933                                                  (U8*)STRING(scan)+STR_LEN(scan));
934                }
935                if (UTF)
936                    SvUTF8_on(data->last_found);
937                data->last_end = data->pos_min + l;
938                data->pos_min += l; /* As in the first entry. */
939                data->flags &= ~SF_BEFORE_EOL;
940            }
941            if (flags & SCF_DO_STCLASS_AND) {
942                /* Check whether it is compatible with what we know already! */
943                int compat = 1;
944
945                if (uc >= 0x100 ||
946                    (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
947                    && !ANYOF_BITMAP_TEST(data->start_class, uc)
948                    && (!(data->start_class->flags & ANYOF_FOLD)
949                        || !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc])))
950                    )
951                    compat = 0;
952                ANYOF_CLASS_ZERO(data->start_class);
953                ANYOF_BITMAP_ZERO(data->start_class);
954                if (compat)
955                    ANYOF_BITMAP_SET(data->start_class, uc);
956                data->start_class->flags &= ~ANYOF_EOS;
957                if (uc < 0x100)
958                  data->start_class->flags &= ~ANYOF_UNICODE_ALL;
959            }
960            else if (flags & SCF_DO_STCLASS_OR) {
961                /* false positive possible if the class is case-folded */
962                if (uc < 0x100)
963                    ANYOF_BITMAP_SET(data->start_class, uc);
964                else
965                    data->start_class->flags |= ANYOF_UNICODE_ALL;
966                data->start_class->flags &= ~ANYOF_EOS;
967                cl_and(data->start_class, &and_with);
968            }
969            flags &= ~SCF_DO_STCLASS;
970        }
971        else if (PL_regkind[(U8)OP(scan)] == EXACT) { /* But OP != EXACT! */
972            I32 l = STR_LEN(scan);
973            UV uc = *((U8*)STRING(scan));
974
975            /* Search for fixed substrings supports EXACT only. */
976            if (flags & SCF_DO_SUBSTR)
977                scan_commit(pRExC_state, data);
978            if (UTF) {
979                U8 *s = (U8 *)STRING(scan);
980                l = utf8_length(s, s + l);
981                uc = utf8_to_uvchr(s, NULL);
982            }
983            min += l;
984            if (data && (flags & SCF_DO_SUBSTR))
985                data->pos_min += l;
986            if (flags & SCF_DO_STCLASS_AND) {
987                /* Check whether it is compatible with what we know already! */
988                int compat = 1;
989
990                if (uc >= 0x100 ||
991                    (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
992                    && !ANYOF_BITMAP_TEST(data->start_class, uc)
993                     && !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc])))
994                    compat = 0;
995                ANYOF_CLASS_ZERO(data->start_class);
996                ANYOF_BITMAP_ZERO(data->start_class);
997                if (compat) {
998                    ANYOF_BITMAP_SET(data->start_class, uc);
999                    data->start_class->flags &= ~ANYOF_EOS;
1000                    data->start_class->flags |= ANYOF_FOLD;
1001                    if (OP(scan) == EXACTFL)
1002                        data->start_class->flags |= ANYOF_LOCALE;
1003                }
1004            }
1005            else if (flags & SCF_DO_STCLASS_OR) {
1006                if (data->start_class->flags & ANYOF_FOLD) {
1007                    /* false positive possible if the class is case-folded.
1008                       Assume that the locale settings are the same... */
1009                    if (uc < 0x100)
1010                        ANYOF_BITMAP_SET(data->start_class, uc);
1011                    data->start_class->flags &= ~ANYOF_EOS;
1012                }
1013                cl_and(data->start_class, &and_with);
1014            }
1015            flags &= ~SCF_DO_STCLASS;
1016        }
1017        else if (strchr((char*)PL_varies,OP(scan))) {
1018            I32 mincount, maxcount, minnext, deltanext, fl = 0;
1019            I32 f = flags, pos_before = 0;
1020            regnode *oscan = scan;
1021            struct regnode_charclass_class this_class;
1022            struct regnode_charclass_class *oclass = NULL;
1023            I32 next_is_eval = 0;
1024
1025            switch (PL_regkind[(U8)OP(scan)]) {
1026            case WHILEM:                /* End of (?:...)* . */
1027                scan = NEXTOPER(scan);
1028                goto finish;
1029            case PLUS:
1030                if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
1031                    next = NEXTOPER(scan);
1032                    if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
1033                        mincount = 1;
1034                        maxcount = REG_INFTY;
1035                        next = regnext(scan);
1036                        scan = NEXTOPER(scan);
1037                        goto do_curly;
1038                    }
1039                }
1040                if (flags & SCF_DO_SUBSTR)
1041                    data->pos_min++;
1042                min++;
1043                /* Fall through. */
1044            case STAR:
1045                if (flags & SCF_DO_STCLASS) {
1046                    mincount = 0;
1047                    maxcount = REG_INFTY;
1048                    next = regnext(scan);
1049                    scan = NEXTOPER(scan);
1050                    goto do_curly;
1051                }
1052                is_inf = is_inf_internal = 1;
1053                scan = regnext(scan);
1054                if (flags & SCF_DO_SUBSTR) {
1055                    scan_commit(pRExC_state, data); /* Cannot extend fixed substrings */
1056                    data->longest = &(data->longest_float);
1057                }
1058                goto optimize_curly_tail;
1059            case CURLY:
1060                mincount = ARG1(scan);
1061                maxcount = ARG2(scan);
1062                next = regnext(scan);
1063                if (OP(scan) == CURLYX) {
1064                    I32 lp = (data ? *(data->last_closep) : 0);
1065
1066                    scan->flags = ((lp <= U8_MAX) ? lp : U8_MAX);
1067                }
1068                scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
1069                next_is_eval = (OP(scan) == EVAL);
1070              do_curly:
1071                if (flags & SCF_DO_SUBSTR) {
1072                    if (mincount == 0) scan_commit(pRExC_state,data); /* Cannot extend fixed substrings */
1073                    pos_before = data->pos_min;
1074                }
1075                if (data) {
1076                    fl = data->flags;
1077                    data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
1078                    if (is_inf)
1079                        data->flags |= SF_IS_INF;
1080                }
1081                if (flags & SCF_DO_STCLASS) {
1082                    cl_init(pRExC_state, &this_class);
1083                    oclass = data->start_class;
1084                    data->start_class = &this_class;
1085                    f |= SCF_DO_STCLASS_AND;
1086                    f &= ~SCF_DO_STCLASS_OR;
1087                }
1088                /* These are the cases when once a subexpression
1089                   fails at a particular position, it cannot succeed
1090                   even after backtracking at the enclosing scope.
1091               
1092                   XXXX what if minimal match and we are at the
1093                        initial run of {n,m}? */
1094                if ((mincount != maxcount - 1) && (maxcount != REG_INFTY))
1095                    f &= ~SCF_WHILEM_VISITED_POS;
1096
1097                /* This will finish on WHILEM, setting scan, or on NULL: */
1098                minnext = study_chunk(pRExC_state, &scan, &deltanext, last, data,
1099                                      mincount == 0
1100                                        ? (f & ~SCF_DO_SUBSTR) : f);
1101
1102                if (flags & SCF_DO_STCLASS)
1103                    data->start_class = oclass;
1104                if (mincount == 0 || minnext == 0) {
1105                    if (flags & SCF_DO_STCLASS_OR) {
1106                        cl_or(pRExC_state, data->start_class, &this_class);
1107                    }
1108                    else if (flags & SCF_DO_STCLASS_AND) {
1109                        /* Switch to OR mode: cache the old value of
1110                         * data->start_class */
1111                        StructCopy(data->start_class, &and_with,
1112                                   struct regnode_charclass_class);
1113                        flags &= ~SCF_DO_STCLASS_AND;
1114                        StructCopy(&this_class, data->start_class,
1115                                   struct regnode_charclass_class);
1116                        flags |= SCF_DO_STCLASS_OR;
1117                        data->start_class->flags |= ANYOF_EOS;
1118                    }
1119                } else {                /* Non-zero len */
1120                    if (flags & SCF_DO_STCLASS_OR) {
1121                        cl_or(pRExC_state, data->start_class, &this_class);
1122                        cl_and(data->start_class, &and_with);
1123                    }
1124                    else if (flags & SCF_DO_STCLASS_AND)
1125                        cl_and(data->start_class, &this_class);
1126                    flags &= ~SCF_DO_STCLASS;
1127                }
1128                if (!scan)              /* It was not CURLYX, but CURLY. */
1129                    scan = next;
1130                if (ckWARN(WARN_REGEXP)
1131                       /* ? quantifier ok, except for (?{ ... }) */
1132                    && (next_is_eval || !(mincount == 0 && maxcount == 1))
1133                    && (minnext == 0) && (deltanext == 0)
1134                    && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
1135                    && maxcount <= REG_INFTY/3) /* Complement check for big count */
1136                {
1137                    vWARN(RExC_parse,
1138                          "Quantifier unexpected on zero-length expression");
1139                }
1140
1141                min += minnext * mincount;
1142                is_inf_internal |= ((maxcount == REG_INFTY
1143                                     && (minnext + deltanext) > 0)
1144                                    || deltanext == I32_MAX);
1145                is_inf |= is_inf_internal;
1146                delta += (minnext + deltanext) * maxcount - minnext * mincount;
1147
1148                /* Try powerful optimization CURLYX => CURLYN. */
1149                if (  OP(oscan) == CURLYX && data
1150                      && data->flags & SF_IN_PAR
1151                      && !(data->flags & SF_HAS_EVAL)
1152                      && !deltanext && minnext == 1 ) {
1153                    /* Try to optimize to CURLYN.  */
1154                    regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
1155                    regnode *nxt1 = nxt;
1156#ifdef DEBUGGING
1157                    regnode *nxt2;
1158#endif
1159
1160                    /* Skip open. */
1161                    nxt = regnext(nxt);
1162                    if (!strchr((char*)PL_simple,OP(nxt))
1163                        && !(PL_regkind[(U8)OP(nxt)] == EXACT
1164                             && STR_LEN(nxt) == 1))
1165                        goto nogo;
1166#ifdef DEBUGGING
1167                    nxt2 = nxt;
1168#endif
1169                    nxt = regnext(nxt);
1170                    if (OP(nxt) != CLOSE)
1171                        goto nogo;
1172                    /* Now we know that nxt2 is the only contents: */
1173                    oscan->flags = (U8)ARG(nxt);
1174                    OP(oscan) = CURLYN;
1175                    OP(nxt1) = NOTHING; /* was OPEN. */
1176#ifdef DEBUGGING
1177                    OP(nxt1 + 1) = OPTIMIZED; /* was count. */
1178                    NEXT_OFF(nxt1+ 1) = 0; /* just for consistancy. */
1179                    NEXT_OFF(nxt2) = 0; /* just for consistancy with CURLY. */
1180                    OP(nxt) = OPTIMIZED;        /* was CLOSE. */
1181                    OP(nxt + 1) = OPTIMIZED; /* was count. */
1182                    NEXT_OFF(nxt+ 1) = 0; /* just for consistancy. */
1183#endif
1184                }
1185              nogo:
1186
1187                /* Try optimization CURLYX => CURLYM. */
1188                if (  OP(oscan) == CURLYX && data
1189                      && !(data->flags & SF_HAS_PAR)
1190                      && !(data->flags & SF_HAS_EVAL)
1191                      && !deltanext  ) {
1192                    /* XXXX How to optimize if data == 0? */
1193                    /* Optimize to a simpler form.  */
1194                    regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
1195                    regnode *nxt2;
1196
1197                    OP(oscan) = CURLYM;
1198                    while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
1199                            && (OP(nxt2) != WHILEM))
1200                        nxt = nxt2;
1201                    OP(nxt2)  = SUCCEED; /* Whas WHILEM */
1202                    /* Need to optimize away parenths. */
1203                    if (data->flags & SF_IN_PAR) {
1204                        /* Set the parenth number.  */
1205                        regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
1206
1207                        if (OP(nxt) != CLOSE)
1208                            FAIL("Panic opt close");
1209                        oscan->flags = (U8)ARG(nxt);
1210                        OP(nxt1) = OPTIMIZED;   /* was OPEN. */
1211                        OP(nxt) = OPTIMIZED;    /* was CLOSE. */
1212#ifdef DEBUGGING
1213                        OP(nxt1 + 1) = OPTIMIZED; /* was count. */
1214                        OP(nxt + 1) = OPTIMIZED; /* was count. */
1215                        NEXT_OFF(nxt1 + 1) = 0; /* just for consistancy. */
1216                        NEXT_OFF(nxt + 1) = 0; /* just for consistancy. */
1217#endif
1218#if 0
1219                        while ( nxt1 && (OP(nxt1) != WHILEM)) {
1220                            regnode *nnxt = regnext(nxt1);
1221                       
1222                            if (nnxt == nxt) {
1223                                if (reg_off_by_arg[OP(nxt1)])
1224                                    ARG_SET(nxt1, nxt2 - nxt1);
1225                                else if (nxt2 - nxt1 < U16_MAX)
1226                                    NEXT_OFF(nxt1) = nxt2 - nxt1;
1227                                else
1228                                    OP(nxt) = NOTHING;  /* Cannot beautify */
1229                            }
1230                            nxt1 = nnxt;
1231                        }
1232#endif
1233                        /* Optimize again: */
1234                        study_chunk(pRExC_state, &nxt1, &deltanext, nxt,
1235                                    NULL, 0);
1236                    }
1237                    else
1238                        oscan->flags = 0;
1239                }
1240                else if ((OP(oscan) == CURLYX)
1241                         && (flags & SCF_WHILEM_VISITED_POS)
1242                         /* See the comment on a similar expression above.
1243                            However, this time it not a subexpression
1244                            we care about, but the expression itself. */
1245                         && (maxcount == REG_INFTY)
1246                         && data && ++data->whilem_c < 16) {
1247                    /* This stays as CURLYX, we can put the count/of pair. */
1248                    /* Find WHILEM (as in regexec.c) */
1249                    regnode *nxt = oscan + NEXT_OFF(oscan);
1250
1251                    if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
1252                        nxt += ARG(nxt);
1253                    PREVOPER(nxt)->flags = (U8)(data->whilem_c
1254                        | (RExC_whilem_seen << 4)); /* On WHILEM */
1255                }
1256                if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
1257                    pars++;
1258                if (flags & SCF_DO_SUBSTR) {
1259                    SV *last_str = Nullsv;
1260                    int counted = mincount != 0;
1261
1262                    if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
1263#if defined(SPARC64_GCC_WORKAROUND)
1264                        I32 b = 0;
1265                        STRLEN l = 0;
1266                        char *s = NULL;
1267                        I32 old = 0;
1268
1269                        if (pos_before >= data->last_start_min)
1270                            b = pos_before;
1271                        else
1272                            b = data->last_start_min;
1273
1274                        l = 0;
1275                        s = SvPV(data->last_found, l);
1276                        old = b - data->last_start_min;
1277
1278#else
1279                        I32 b = pos_before >= data->last_start_min
1280                            ? pos_before : data->last_start_min;
1281                        STRLEN l;
1282                        char *s = SvPV(data->last_found, l);
1283                        I32 old = b - data->last_start_min;
1284#endif
1285
1286                        if (UTF)
1287                            old = utf8_hop((U8*)s, old) - (U8*)s;
1288                       
1289                        l -= old;
1290                        /* Get the added string: */
1291                        last_str = newSVpvn(s  + old, l);
1292                        if (UTF)
1293                            SvUTF8_on(last_str);
1294                        if (deltanext == 0 && pos_before == b) {
1295                            /* What was added is a constant string */
1296                            if (mincount > 1) {
1297                                SvGROW(last_str, (mincount * l) + 1);
1298                                repeatcpy(SvPVX(last_str) + l,
1299                                          SvPVX(last_str), l, mincount - 1);
1300                                SvCUR(last_str) *= mincount;
1301                                /* Add additional parts. */
1302                                SvCUR_set(data->last_found,
1303                                          SvCUR(data->last_found) - l);
1304                                sv_catsv(data->last_found, last_str);
1305                                {
1306                                    SV * sv = data->last_found;
1307                                    MAGIC *mg =
1308                                        SvUTF8(sv) && SvMAGICAL(sv) ?
1309                                        mg_find(sv, PERL_MAGIC_utf8) : NULL;
1310                                    if (mg && mg->mg_len >= 0)
1311                                        mg->mg_len += CHR_SVLEN(last_str);
1312                                }
1313                                data->last_end += l * (mincount - 1);
1314                            }
1315                        } else {
1316                            /* start offset must point into the last copy */
1317                            data->last_start_min += minnext * (mincount - 1);
1318                            data->last_start_max += is_inf ? I32_MAX
1319                                : (maxcount - 1) * (minnext + data->pos_delta);
1320                        }
1321                    }
1322                    /* It is counted once already... */
1323                    data->pos_min += minnext * (mincount - counted);
1324                    data->pos_delta += - counted * deltanext +
1325                        (minnext + deltanext) * maxcount - minnext * mincount;
1326                    if (mincount != maxcount) {
1327                         /* Cannot extend fixed substrings found inside
1328                            the group.  */
1329                        scan_commit(pRExC_state,data);
1330                        if (mincount && last_str) {
1331                            sv_setsv(data->last_found, last_str);
1332                            data->last_end = data->pos_min;
1333                            data->last_start_min =
1334                                data->pos_min - CHR_SVLEN(last_str);
1335                            data->last_start_max = is_inf
1336                                ? I32_MAX
1337                                : data->pos_min + data->pos_delta
1338                                - CHR_SVLEN(last_str);
1339                        }
1340                        data->longest = &(data->longest_float);
1341                    }
1342                    SvREFCNT_dec(last_str);
1343                }
1344                if (data && (fl & SF_HAS_EVAL))
1345                    data->flags |= SF_HAS_EVAL;
1346              optimize_curly_tail:
1347                if (OP(oscan) != CURLYX) {
1348                    while (PL_regkind[(U8)OP(next = regnext(oscan))] == NOTHING
1349                           && NEXT_OFF(next))
1350                        NEXT_OFF(oscan) += NEXT_OFF(next);
1351                }
1352                continue;
1353            default:                    /* REF and CLUMP only? */
1354                if (flags & SCF_DO_SUBSTR) {
1355                    scan_commit(pRExC_state,data);      /* Cannot expect anything... */
1356                    data->longest = &(data->longest_float);
1357                }
1358                is_inf = is_inf_internal = 1;
1359                if (flags & SCF_DO_STCLASS_OR)
1360                    cl_anything(pRExC_state, data->start_class);
1361                flags &= ~SCF_DO_STCLASS;
1362                break;
1363            }
1364        }
1365        else if (strchr((char*)PL_simple,OP(scan))) {
1366            int value = 0;
1367
1368            if (flags & SCF_DO_SUBSTR) {
1369                scan_commit(pRExC_state,data);
1370                data->pos_min++;
1371            }
1372            min++;
1373            if (flags & SCF_DO_STCLASS) {
1374                data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
1375
1376                /* Some of the logic below assumes that switching
1377                   locale on will only add false positives. */
1378                switch (PL_regkind[(U8)OP(scan)]) {
1379                case SANY:
1380                default:
1381                  do_default:
1382                    /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
1383                    if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
1384                        cl_anything(pRExC_state, data->start_class);
1385                    break;
1386                case REG_ANY:
1387                    if (OP(scan) == SANY)
1388                        goto do_default;
1389                    if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
1390                        value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
1391                                 || (data->start_class->flags & ANYOF_CLASS));
1392                        cl_anything(pRExC_state, data->start_class);
1393                    }
1394                    if (flags & SCF_DO_STCLASS_AND || !value)
1395                        ANYOF_BITMAP_CLEAR(data->start_class,'\n');
1396                    break;
1397                case ANYOF:
1398                    if (flags & SCF_DO_STCLASS_AND)
1399                        cl_and(data->start_class,
1400                               (struct regnode_charclass_class*)scan);
1401                    else
1402                        cl_or(pRExC_state, data->start_class,
1403                              (struct regnode_charclass_class*)scan);
1404                    break;
1405                case ALNUM:
1406                    if (flags & SCF_DO_STCLASS_AND) {
1407                        if (!(data->start_class->flags & ANYOF_LOCALE)) {
1408                            ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
1409                            for (value = 0; value < 256; value++)
1410                                if (!isALNUM(value))
1411                                    ANYOF_BITMAP_CLEAR(data->start_class, value);
1412                        }
1413                    }
1414                    else {
1415                        if (data->start_class->flags & ANYOF_LOCALE)
1416                            ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
1417                        else {
1418                            for (value = 0; value < 256; value++)
1419                                if (isALNUM(value))
1420                                    ANYOF_BITMAP_SET(data->start_class, value);                 
1421                        }
1422                    }
1423                    break;
1424                case ALNUML:
1425                    if (flags & SCF_DO_STCLASS_AND) {
1426                        if (data->start_class->flags & ANYOF_LOCALE)
1427                            ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
1428                    }
1429                    else {
1430                        ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
1431                        data->start_class->flags |= ANYOF_LOCALE;
1432                    }
1433                    break;
1434                case NALNUM:
1435                    if (flags & SCF_DO_STCLASS_AND) {
1436                        if (!(data->start_class->flags & ANYOF_LOCALE)) {
1437                            ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
1438                            for (value = 0; value < 256; value++)
1439                                if (isALNUM(value))
1440                                    ANYOF_BITMAP_CLEAR(data->start_class, value);
1441                        }
1442                    }
1443                    else {
1444                        if (data->start_class->flags & ANYOF_LOCALE)
1445                            ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
1446                        else {
1447                            for (value = 0; value < 256; value++)
1448                                if (!isALNUM(value))
1449                                    ANYOF_BITMAP_SET(data->start_class, value);                 
1450                        }
1451                    }
1452                    break;
1453                case NALNUML:
1454                    if (flags & SCF_DO_STCLASS_AND) {
1455                        if (data->start_class->flags & ANYOF_LOCALE)
1456                            ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
1457                    }
1458                    else {
1459                        data->start_class->flags |= ANYOF_LOCALE;
1460                        ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
1461                    }
1462                    break;
1463                case SPACE:
1464                    if (flags & SCF_DO_STCLASS_AND) {
1465                        if (!(data->start_class->flags & ANYOF_LOCALE)) {
1466                            ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
1467                            for (value = 0; value < 256; value++)
1468                                if (!isSPACE(value))
1469                                    ANYOF_BITMAP_CLEAR(data->start_class, value);
1470                        }
1471                    }
1472                    else {
1473                        if (data->start_class->flags & ANYOF_LOCALE)
1474                            ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
1475                        else {
1476                            for (value = 0; value < 256; value++)
1477                                if (isSPACE(value))
1478                                    ANYOF_BITMAP_SET(data->start_class, value);                 
1479                        }
1480                    }
1481                    break;
1482                case SPACEL:
1483                    if (flags & SCF_DO_STCLASS_AND) {
1484                        if (data->start_class->flags & ANYOF_LOCALE)
1485                            ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
1486                    }
1487                    else {
1488                        data->start_class->flags |= ANYOF_LOCALE;
1489                        ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
1490                    }
1491                    break;
1492                case NSPACE:
1493                    if (flags & SCF_DO_STCLASS_AND) {
1494                        if (!(data->start_class->flags & ANYOF_LOCALE)) {
1495                            ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
1496                            for (value = 0; value < 256; value++)
1497                                if (isSPACE(value))
1498                                    ANYOF_BITMAP_CLEAR(data->start_class, value);
1499                        }
1500                    }
1501                    else {
1502                        if (data->start_class->flags & ANYOF_LOCALE)
1503                            ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
1504                        else {
1505                            for (value = 0; value < 256; value++)
1506                                if (!isSPACE(value))
1507                                    ANYOF_BITMAP_SET(data->start_class, value);                 
1508                        }
1509                    }
1510                    break;
1511                case NSPACEL:
1512                    if (flags & SCF_DO_STCLASS_AND) {
1513                        if (data->start_class->flags & ANYOF_LOCALE) {
1514                            ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
1515                            for (value = 0; value < 256; value++)
1516                                if (!isSPACE(value))
1517                                    ANYOF_BITMAP_CLEAR(data->start_class, value);
1518                        }
1519                    }
1520                    else {
1521                        data->start_class->flags |= ANYOF_LOCALE;
1522                        ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
1523                    }
1524                    break;
1525                case DIGIT:
1526                    if (flags & SCF_DO_STCLASS_AND) {
1527                        ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT);
1528                        for (value = 0; value < 256; value++)
1529                            if (!isDIGIT(value))
1530                                ANYOF_BITMAP_CLEAR(data->start_class, value);
1531                    }
1532                    else {
1533                        if (data->start_class->flags & ANYOF_LOCALE)
1534                            ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT);
1535                        else {
1536                            for (value = 0; value < 256; value++)
1537                                if (isDIGIT(value))
1538                                    ANYOF_BITMAP_SET(data->start_class, value);                 
1539                        }
1540                    }
1541                    break;
1542                case NDIGIT:
1543                    if (flags & SCF_DO_STCLASS_AND) {
1544                        ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT);
1545                        for (value = 0; value < 256; value++)
1546                            if (isDIGIT(value))
1547                                ANYOF_BITMAP_CLEAR(data->start_class, value);
1548                    }
1549                    else {
1550                        if (data->start_class->flags & ANYOF_LOCALE)
1551                            ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT);
1552                        else {
1553                            for (value = 0; value < 256; value++)
1554                                if (!isDIGIT(value))
1555                                    ANYOF_BITMAP_SET(data->start_class, value);                 
1556                        }
1557                    }
1558                    break;
1559                }
1560                if (flags & SCF_DO_STCLASS_OR)
1561                    cl_and(data->start_class, &and_with);
1562                flags &= ~SCF_DO_STCLASS;
1563            }
1564        }
1565        else if (PL_regkind[(U8)OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
1566            data->flags |= (OP(scan) == MEOL
1567                            ? SF_BEFORE_MEOL
1568                            : SF_BEFORE_SEOL);
1569        }
1570        else if (  PL_regkind[(U8)OP(scan)] == BRANCHJ
1571                 /* Lookbehind, or need to calculate parens/evals/stclass: */
1572                   && (scan->flags || data || (flags & SCF_DO_STCLASS))
1573                   && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
1574            /* Lookahead/lookbehind */
1575            I32 deltanext, minnext, fake = 0;
1576            regnode *nscan;
1577            struct regnode_charclass_class intrnl;
1578            int f = 0;
1579
1580            data_fake.flags = 0;
1581            if (data) {         
1582                data_fake.whilem_c = data->whilem_c;
1583                data_fake.last_closep = data->last_closep;
1584            }
1585            else
1586                data_fake.last_closep = &fake;
1587            if ( flags & SCF_DO_STCLASS && !scan->flags
1588                 && OP(scan) == IFMATCH ) { /* Lookahead */
1589                cl_init(pRExC_state, &intrnl);
1590                data_fake.start_class = &intrnl;
1591                f |= SCF_DO_STCLASS_AND;
1592            }
1593            if (flags & SCF_WHILEM_VISITED_POS)
1594                f |= SCF_WHILEM_VISITED_POS;
1595            next = regnext(scan);
1596            nscan = NEXTOPER(NEXTOPER(scan));
1597            minnext = study_chunk(pRExC_state, &nscan, &deltanext, last, &data_fake, f);
1598            if (scan->flags) {
1599                if (deltanext) {
1600                    vFAIL("Variable length lookbehind not implemented");
1601                }
1602                else if (minnext > U8_MAX) {
1603                    vFAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
1604                }
1605                scan->flags = (U8)minnext;
1606            }
1607            if (data && data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
1608                pars++;
1609            if (data && (data_fake.flags & SF_HAS_EVAL))
1610                data->flags |= SF_HAS_EVAL;
1611            if (data)
1612                data->whilem_c = data_fake.whilem_c;
1613            if (f & SCF_DO_STCLASS_AND) {
1614                int was = (data->start_class->flags & ANYOF_EOS);
1615
1616                cl_and(data->start_class, &intrnl);
1617                if (was)
1618                    data->start_class->flags |= ANYOF_EOS;
1619            }
1620        }
1621        else if (OP(scan) == OPEN) {
1622            pars++;
1623        }
1624        else if (OP(scan) == CLOSE) {
1625            if ((I32)ARG(scan) == is_par) {
1626                next = regnext(scan);
1627
1628                if ( next && (OP(next) != WHILEM) && next < last)
1629                    is_par = 0;         /* Disable optimization */
1630            }
1631            if (data)
1632                *(data->last_closep) = ARG(scan);
1633        }
1634        else if (OP(scan) == EVAL) {
1635                if (data)
1636                    data->flags |= SF_HAS_EVAL;
1637        }
1638        else if (OP(scan) == LOGICAL && scan->flags == 2) { /* Embedded follows */
1639                if (flags & SCF_DO_SUBSTR) {
1640                    scan_commit(pRExC_state,data);
1641                    data->longest = &(data->longest_float);
1642                }
1643                is_inf = is_inf_internal = 1;
1644                if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
1645                    cl_anything(pRExC_state, data->start_class);
1646                flags &= ~SCF_DO_STCLASS;
1647        }
1648        /* Else: zero-length, ignore. */
1649        scan = regnext(scan);
1650    }
1651
1652  finish:
1653    *scanp = scan;
1654    *deltap = is_inf_internal ? I32_MAX : delta;
1655    if (flags & SCF_DO_SUBSTR && is_inf)
1656        data->pos_delta = I32_MAX - data->pos_min;
1657    if (is_par > U8_MAX)
1658        is_par = 0;
1659    if (is_par && pars==1 && data) {
1660        data->flags |= SF_IN_PAR;
1661        data->flags &= ~SF_HAS_PAR;
1662    }
1663    else if (pars && data) {
1664        data->flags |= SF_HAS_PAR;
1665        data->flags &= ~SF_IN_PAR;
1666    }
1667    if (flags & SCF_DO_STCLASS_OR)
1668        cl_and(data->start_class, &and_with);
1669    return min;
1670}
1671
1672STATIC I32
1673S_add_data(pTHX_ RExC_state_t *pRExC_state, I32 n, char *s)
1674{
1675    if (RExC_rx->data) {
1676        Renewc(RExC_rx->data,
1677               sizeof(*RExC_rx->data) + sizeof(void*) * (RExC_rx->data->count + n - 1),
1678               char, struct reg_data);
1679        Renew(RExC_rx->data->what, RExC_rx->data->count + n, U8);
1680        RExC_rx->data->count += n;
1681    }
1682    else {
1683        Newc(1207, RExC_rx->data, sizeof(*RExC_rx->data) + sizeof(void*) * (n - 1),
1684             char, struct reg_data);
1685        New(1208, RExC_rx->data->what, n, U8);
1686        RExC_rx->data->count = n;
1687    }
1688    Copy(s, RExC_rx->data->what + RExC_rx->data->count - n, n, U8);
1689    return RExC_rx->data->count - n;
1690}
1691
1692void
1693Perl_reginitcolors(pTHX)
1694{
1695    int i = 0;
1696    char *s = PerlEnv_getenv("PERL_RE_COLORS");
1697       
1698    if (s) {
1699        PL_colors[0] = s = savepv(s);
1700        while (++i < 6) {
1701            s = strchr(s, '\t');
1702            if (s) {
1703                *s = '\0';
1704                PL_colors[i] = ++s;
1705            }
1706            else
1707                PL_colors[i] = s = "";
1708        }
1709    } else {
1710        while (i < 6)
1711            PL_colors[i++] = "";
1712    }
1713    PL_colorset = 1;
1714}
1715
1716
1717/*
1718 - pregcomp - compile a regular expression into internal code
1719 *
1720 * We can't allocate space until we know how big the compiled form will be,
1721 * but we can't compile it (and thus know how big it is) until we've got a
1722 * place to put the code.  So we cheat:  we compile it twice, once with code
1723 * generation turned off and size counting turned on, and once "for real".
1724 * This also means that we don't allocate space until we are sure that the
1725 * thing really will compile successfully, and we never have to move the
1726 * code and thus invalidate pointers into it.  (Note that it has to be in
1727 * one piece because free() must be able to free it all.) [NB: not true in perl]
1728 *
1729 * Beware that the optimization-preparation code in here knows about some
1730 * of the structure of the compiled regexp.  [I'll say.]
1731 */
1732regexp *
1733Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
1734{
1735    register regexp *r;
1736    regnode *scan;
1737    regnode *first;
1738    I32 flags;
1739    I32 minlen = 0;
1740    I32 sawplus = 0;
1741    I32 sawopen = 0;
1742    scan_data_t data;
1743    RExC_state_t RExC_state;
1744    RExC_state_t *pRExC_state = &RExC_state;
1745
1746    if (exp == NULL)
1747        FAIL("NULL regexp argument");
1748
1749    RExC_utf8 = pm->op_pmdynflags & PMdf_CMP_UTF8;
1750
1751    RExC_precomp = exp;
1752    DEBUG_r({
1753         if (!PL_colorset) reginitcolors();
1754         PerlIO_printf(Perl_debug_log, "%sCompiling REx%s `%s%*s%s'\n",
1755                       PL_colors[4],PL_colors[5],PL_colors[0],
1756                       (int)(xend - exp), RExC_precomp, PL_colors[1]);
1757    });
1758    RExC_flags = pm->op_pmflags;
1759    RExC_sawback = 0;
1760
1761    RExC_seen = 0;
1762    RExC_seen_zerolen = *exp == '^' ? -1 : 0;
1763    RExC_seen_evals = 0;
1764    RExC_extralen = 0;
1765
1766    /* First pass: determine size, legality. */
1767    RExC_parse = exp;
1768    RExC_start = exp;
1769    RExC_end = xend;
1770    RExC_naughty = 0;
1771    RExC_npar = 1;
1772    RExC_size = 0L;
1773    RExC_emit = &PL_regdummy;
1774    RExC_whilem_seen = 0;
1775#if 0 /* REGC() is (currently) a NOP at the first pass.
1776       * Clever compilers notice this and complain. --jhi */
1777    REGC((U8)REG_MAGIC, (char*)RExC_emit);
1778#endif
1779    if (reg(pRExC_state, 0, &flags) == NULL) {
1780        RExC_precomp = Nullch;
1781        return(NULL);
1782    }
1783    DEBUG_r(PerlIO_printf(Perl_debug_log, "size %"IVdf" ", (IV)RExC_size));
1784
1785    /* Small enough for pointer-storage convention?
1786       If extralen==0, this means that we will not need long jumps. */
1787    if (RExC_size >= 0x10000L && RExC_extralen)
1788        RExC_size += RExC_extralen;
1789    else
1790        RExC_extralen = 0;
1791    if (RExC_whilem_seen > 15)
1792        RExC_whilem_seen = 15;
1793
1794    /* Allocate space and initialize. */
1795    Newc(1001, r, sizeof(regexp) + (unsigned)RExC_size * sizeof(regnode),
1796         char, regexp);
1797    if (r == NULL)
1798        FAIL("Regexp out of space");
1799
1800#ifdef DEBUGGING
1801    /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
1802    Zero(r, sizeof(regexp) + (unsigned)RExC_size * sizeof(regnode), char);
1803#endif
1804    r->refcnt = 1;
1805    r->prelen = xend - exp;
1806    r->precomp = savepvn(RExC_precomp, r->prelen);
1807    r->subbeg = NULL;
1808    r->reganch = pm->op_pmflags & PMf_COMPILETIME;
1809    r->nparens = RExC_npar - 1; /* set early to validate backrefs */
1810
1811    r->substrs = 0;                     /* Useful during FAIL. */
1812    r->startp = 0;                      /* Useful during FAIL. */
1813    r->endp = 0;                        /* Useful during FAIL. */
1814
1815    Newz(1304, r->offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
1816    if (r->offsets) {
1817      r->offsets[0] = RExC_size;
1818    }
1819    DEBUG_r(PerlIO_printf(Perl_debug_log,
1820                          "%s %"UVuf" bytes for offset annotations.\n",
1821                          r->offsets ? "Got" : "Couldn't get",
1822                          (UV)((2*RExC_size+1) * sizeof(U32))));
1823
1824    RExC_rx = r;
1825
1826    /* Second pass: emit code. */
1827    RExC_flags = pm->op_pmflags;        /* don't let top level (?i) bleed */
1828    RExC_parse = exp;
1829    RExC_end = xend;
1830    RExC_naughty = 0;
1831    RExC_npar = 1;
1832    RExC_emit_start = r->program;
1833    RExC_emit = r->program;
1834    /* Store the count of eval-groups for security checks: */
1835    RExC_emit->next_off = (U16)((RExC_seen_evals > U16_MAX) ? U16_MAX : RExC_seen_evals);
1836    REGC((U8)REG_MAGIC, (char*) RExC_emit++);
1837    r->data = 0;
1838    if (reg(pRExC_state, 0, &flags) == NULL)
1839        return(NULL);
1840
1841    /* Dig out information for optimizations. */
1842    r->reganch = pm->op_pmflags & PMf_COMPILETIME; /* Again? */
1843    pm->op_pmflags = RExC_flags;
1844    if (UTF)
1845        r->reganch |= ROPT_UTF8;        /* Unicode in it? */
1846    r->regstclass = NULL;
1847    if (RExC_naughty >= 10)     /* Probably an expensive pattern. */
1848        r->reganch |= ROPT_NAUGHTY;
1849    scan = r->program + 1;              /* First BRANCH. */
1850
1851    /* XXXX To minimize changes to RE engine we always allocate
1852       3-units-long substrs field. */
1853    Newz(1004, r->substrs, 1, struct reg_substr_data);
1854
1855    StructCopy(&zero_scan_data, &data, scan_data_t);
1856    /* XXXX Should not we check for something else?  Usually it is OPEN1... */
1857    if (OP(scan) != BRANCH) {   /* Only one top-level choice. */
1858        I32 fake;
1859        STRLEN longest_float_length, longest_fixed_length;
1860        struct regnode_charclass_class ch_class;
1861        int stclass_flag;
1862        I32 last_close = 0;
1863
1864        first = scan;
1865        /* Skip introductions and multiplicators >= 1. */
1866        while ((OP(first) == OPEN && (sawopen = 1)) ||
1867               /* An OR of *one* alternative - should not happen now. */
1868            (OP(first) == BRANCH && OP(regnext(first)) != BRANCH) ||
1869            (OP(first) == PLUS) ||
1870            (OP(first) == MINMOD) ||
1871               /* An {n,m} with n>0 */
1872            (PL_regkind[(U8)OP(first)] == CURLY && ARG1(first) > 0) ) {
1873                if (OP(first) == PLUS)
1874                    sawplus = 1;
1875                else
1876                    first += regarglen[(U8)OP(first)];
1877                first = NEXTOPER(first);
1878        }
1879
1880        /* Starting-point info. */
1881      again:
1882        if (PL_regkind[(U8)OP(first)] == EXACT) {
1883            if (OP(first) == EXACT)
1884                ;       /* Empty, get anchored substr later. */
1885            else if ((OP(first) == EXACTF || OP(first) == EXACTFL))
1886                r->regstclass = first;
1887        }
1888        else if (strchr((char*)PL_simple,OP(first)))
1889            r->regstclass = first;
1890        else if (PL_regkind[(U8)OP(first)] == BOUND ||
1891                 PL_regkind[(U8)OP(first)] == NBOUND)
1892            r->regstclass = first;
1893        else if (PL_regkind[(U8)OP(first)] == BOL) {
1894            r->reganch |= (OP(first) == MBOL
1895                           ? ROPT_ANCH_MBOL
1896                           : (OP(first) == SBOL
1897                              ? ROPT_ANCH_SBOL
1898                              : ROPT_ANCH_BOL));
1899            first = NEXTOPER(first);
1900            goto again;
1901        }
1902        else if (OP(first) == GPOS) {
1903            r->reganch |= ROPT_ANCH_GPOS;
1904            first = NEXTOPER(first);
1905            goto again;
1906        }
1907        else if (!sawopen && (OP(first) == STAR &&
1908            PL_regkind[(U8)OP(NEXTOPER(first))] == REG_ANY) &&
1909            !(r->reganch & ROPT_ANCH) )
1910        {
1911            /* turn .* into ^.* with an implied $*=1 */
1912            int type = OP(NEXTOPER(first));
1913
1914            if (type == REG_ANY)
1915                type = ROPT_ANCH_MBOL;
1916            else
1917                type = ROPT_ANCH_SBOL;
1918
1919            r->reganch |= type | ROPT_IMPLICIT;
1920            first = NEXTOPER(first);
1921            goto again;
1922        }
1923        if (sawplus && (!sawopen || !RExC_sawback)
1924            && !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */
1925            /* x+ must match at the 1st pos of run of x's */
1926            r->reganch |= ROPT_SKIP;
1927
1928        /* Scan is after the zeroth branch, first is atomic matcher. */
1929        DEBUG_r(PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
1930                              (IV)(first - scan + 1)));
1931        /*
1932        * If there's something expensive in the r.e., find the
1933        * longest literal string that must appear and make it the
1934        * regmust.  Resolve ties in favor of later strings, since
1935        * the regstart check works with the beginning of the r.e.
1936        * and avoiding duplication strengthens checking.  Not a
1937        * strong reason, but sufficient in the absence of others.
1938        * [Now we resolve ties in favor of the earlier string if
1939        * it happens that c_offset_min has been invalidated, since the
1940        * earlier string may buy us something the later one won't.]
1941        */
1942        minlen = 0;
1943
1944        data.longest_fixed = newSVpvn("",0);
1945        data.longest_float = newSVpvn("",0);
1946        data.last_found = newSVpvn("",0);
1947        data.longest = &(data.longest_fixed);
1948        first = scan;
1949        if (!r->regstclass) {
1950            cl_init(pRExC_state, &ch_class);
1951            data.start_class = &ch_class;
1952            stclass_flag = SCF_DO_STCLASS_AND;
1953        } else                          /* XXXX Check for BOUND? */
1954            stclass_flag = 0;
1955        data.last_closep = &last_close;
1956
1957        minlen = study_chunk(pRExC_state, &first, &fake, scan + RExC_size, /* Up to end */
1958                             &data, SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag);
1959        if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
1960             && data.last_start_min == 0 && data.last_end > 0
1961             && !RExC_seen_zerolen
1962             && (!(RExC_seen & REG_SEEN_GPOS) || (r->reganch & ROPT_ANCH_GPOS)))
1963            r->reganch |= ROPT_CHECK_ALL;
1964        scan_commit(pRExC_state, &data);
1965        SvREFCNT_dec(data.last_found);
1966
1967        longest_float_length = CHR_SVLEN(data.longest_float);
1968        if (longest_float_length
1969            || (data.flags & SF_FL_BEFORE_EOL
1970                && (!(data.flags & SF_FL_BEFORE_MEOL)
1971                    || (RExC_flags & PMf_MULTILINE)))) {
1972            int t;
1973
1974            if (SvCUR(data.longest_fixed)                       /* ok to leave SvCUR */
1975                && data.offset_fixed == data.offset_float_min
1976                && SvCUR(data.longest_fixed) == SvCUR(data.longest_float))
1977                    goto remove_float;          /* As in (a)+. */
1978
1979            if (SvUTF8(data.longest_float)) {
1980                r->float_utf8 = data.longest_float;
1981                r->float_substr = Nullsv;
1982            } else {
1983                r->float_substr = data.longest_float;
1984                r->float_utf8 = Nullsv;
1985            }
1986            r->float_min_offset = data.offset_float_min;
1987            r->float_max_offset = data.offset_float_max;
1988            t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
1989                       && (!(data.flags & SF_FL_BEFORE_MEOL)
1990                           || (RExC_flags & PMf_MULTILINE)));
1991            fbm_compile(data.longest_float, t ? FBMcf_TAIL : 0);
1992        }
1993        else {
1994          remove_float:
1995            r->float_substr = r->float_utf8 = Nullsv;
1996            SvREFCNT_dec(data.longest_float);
1997            longest_float_length = 0;
1998        }
1999
2000        longest_fixed_length = CHR_SVLEN(data.longest_fixed);
2001        if (longest_fixed_length
2002            || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
2003                && (!(data.flags & SF_FIX_BEFORE_MEOL)
2004                    || (RExC_flags & PMf_MULTILINE)))) {
2005            int t;
2006
2007            if (SvUTF8(data.longest_fixed)) {
2008                r->anchored_utf8 = data.longest_fixed;
2009                r->anchored_substr = Nullsv;
2010            } else {
2011                r->anchored_substr = data.longest_fixed;
2012                r->anchored_utf8 = Nullsv;
2013            }
2014            r->anchored_offset = data.offset_fixed;
2015            t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
2016                 && (!(data.flags & SF_FIX_BEFORE_MEOL)
2017                     || (RExC_flags & PMf_MULTILINE)));
2018            fbm_compile(data.longest_fixed, t ? FBMcf_TAIL : 0);
2019        }
2020        else {
2021            r->anchored_substr = r->anchored_utf8 = Nullsv;
2022            SvREFCNT_dec(data.longest_fixed);
2023            longest_fixed_length = 0;
2024        }
2025        if (r->regstclass
2026            && (OP(r->regstclass) == REG_ANY || OP(r->regstclass) == SANY))
2027            r->regstclass = NULL;
2028        if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
2029            && stclass_flag
2030            && !(data.start_class->flags & ANYOF_EOS)
2031            && !cl_is_anything(data.start_class))
2032        {
2033            I32 n = add_data(pRExC_state, 1, "f");
2034
2035            New(1006, RExC_rx->data->data[n], 1,
2036                struct regnode_charclass_class);
2037            StructCopy(data.start_class,
2038                       (struct regnode_charclass_class*)RExC_rx->data->data[n],
2039                       struct regnode_charclass_class);
2040            r->regstclass = (regnode*)RExC_rx->data->data[n];
2041            r->reganch &= ~ROPT_SKIP;   /* Used in find_byclass(). */
2042            PL_regdata = r->data; /* for regprop() */
2043            DEBUG_r({ SV *sv = sv_newmortal();
2044                      regprop(sv, (regnode*)data.start_class);
2045                      PerlIO_printf(Perl_debug_log,
2046                                    "synthetic stclass `%s'.\n",
2047                                    SvPVX(sv));});
2048        }
2049
2050        /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
2051        if (longest_fixed_length > longest_float_length) {
2052            r->check_substr = r->anchored_substr;
2053            r->check_utf8 = r->anchored_utf8;
2054            r->check_offset_min = r->check_offset_max = r->anchored_offset;
2055            if (r->reganch & ROPT_ANCH_SINGLE)
2056                r->reganch |= ROPT_NOSCAN;
2057        }
2058        else {
2059            r->check_substr = r->float_substr;
2060            r->check_utf8 = r->float_utf8;
2061            r->check_offset_min = data.offset_float_min;
2062            r->check_offset_max = data.offset_float_max;
2063        }
2064        /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
2065           This should be changed ASAP!  */
2066        if ((r->check_substr || r->check_utf8) && !(r->reganch & ROPT_ANCH_GPOS)) {
2067            r->reganch |= RE_USE_INTUIT;
2068            if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
2069                r->reganch |= RE_INTUIT_TAIL;
2070        }
2071    }
2072    else {
2073        /* Several toplevels. Best we can is to set minlen. */
2074        I32 fake;
2075        struct regnode_charclass_class ch_class;
2076        I32 last_close = 0;
2077       
2078        DEBUG_r(PerlIO_printf(Perl_debug_log, "\n"));
2079        scan = r->program + 1;
2080        cl_init(pRExC_state, &ch_class);
2081        data.start_class = &ch_class;
2082        data.last_closep = &last_close;
2083        minlen = study_chunk(pRExC_state, &scan, &fake, scan + RExC_size, &data, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS);
2084        r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
2085                = r->float_substr = r->float_utf8 = Nullsv;
2086        if (!(data.start_class->flags & ANYOF_EOS)
2087            && !cl_is_anything(data.start_class))
2088        {
2089            I32 n = add_data(pRExC_state, 1, "f");
2090
2091            New(1006, RExC_rx->data->data[n], 1,
2092                struct regnode_charclass_class);
2093            StructCopy(data.start_class,
2094                       (struct regnode_charclass_class*)RExC_rx->data->data[n],
2095                       struct regnode_charclass_class);
2096            r->regstclass = (regnode*)RExC_rx->data->data[n];
2097            r->reganch &= ~ROPT_SKIP;   /* Used in find_byclass(). */
2098            DEBUG_r({ SV* sv = sv_newmortal();
2099                      regprop(sv, (regnode*)data.start_class);
2100                      PerlIO_printf(Perl_debug_log,
2101                                    "synthetic stclass `%s'.\n",
2102                                    SvPVX(sv));});
2103        }
2104    }
2105
2106    r->minlen = minlen;
2107    if (RExC_seen & REG_SEEN_GPOS)
2108        r->reganch |= ROPT_GPOS_SEEN;
2109    if (RExC_seen & REG_SEEN_LOOKBEHIND)
2110        r->reganch |= ROPT_LOOKBEHIND_SEEN;
2111    if (RExC_seen & REG_SEEN_EVAL)
2112        r->reganch |= ROPT_EVAL_SEEN;
2113    if (RExC_seen & REG_SEEN_CANY)
2114        r->reganch |= ROPT_CANY_SEEN;
2115    Newz(1002, r->startp, RExC_npar, I32);
2116    Newz(1002, r->endp, RExC_npar, I32);
2117    PL_regdata = r->data; /* for regprop() */
2118    DEBUG_r(regdump(r));
2119    return(r);
2120}
2121
2122/*
2123 - reg - regular expression, i.e. main body or parenthesized thing
2124 *
2125 * Caller must absorb opening parenthesis.
2126 *
2127 * Combining parenthesis handling with the base level of regular expression
2128 * is a trifle forced, but the need to tie the tails of the branches to what
2129 * follows makes it hard to avoid.
2130 */
2131STATIC regnode *
2132S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp)
2133    /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
2134{
2135    register regnode *ret;              /* Will be the head of the group. */
2136    register regnode *br;
2137    register regnode *lastbr;
2138    register regnode *ender = 0;
2139    register I32 parno = 0;
2140    I32 flags, oregflags = RExC_flags, have_branch = 0, open = 0;
2141
2142    /* for (?g), (?gc), and (?o) warnings; warning
2143       about (?c) will warn about (?g) -- japhy    */
2144
2145    I32 wastedflags = 0x00,
2146        wasted_o    = 0x01,
2147        wasted_g    = 0x02,
2148        wasted_gc   = 0x02 | 0x04,
2149        wasted_c    = 0x04;
2150
2151    char * parse_start = RExC_parse; /* MJD */
2152    char *oregcomp_parse = RExC_parse;
2153    char c;
2154
2155    *flagp = 0;                         /* Tentatively. */
2156
2157
2158    /* Make an OPEN node, if parenthesized. */
2159    if (paren) {
2160        if (*RExC_parse == '?') { /* (?...) */
2161            U32 posflags = 0, negflags = 0;
2162            U32 *flagsp = &posflags;
2163            int logical = 0;
2164            char *seqstart = RExC_parse;
2165
2166            RExC_parse++;
2167            paren = *RExC_parse++;
2168            ret = NULL;                 /* For look-ahead/behind. */
2169            switch (paren) {
2170            case '<':           /* (?<...) */
2171                RExC_seen |= REG_SEEN_LOOKBEHIND;
2172                if (*RExC_parse == '!')
2173                    paren = ',';
2174                if (*RExC_parse != '=' && *RExC_parse != '!')
2175                    goto unknown;
2176                RExC_parse++;
2177            case '=':           /* (?=...) */
2178            case '!':           /* (?!...) */
2179                RExC_seen_zerolen++;
2180            case ':':           /* (?:...) */
2181            case '>':           /* (?>...) */
2182                break;
2183            case '$':           /* (?$...) */
2184            case '@':           /* (?@...) */
2185                vFAIL2("Sequence (?%c...) not implemented", (int)paren);
2186                break;
2187            case '#':           /* (?#...) */
2188                while (*RExC_parse && *RExC_parse != ')')
2189                    RExC_parse++;
2190                if (*RExC_parse != ')')
2191                    FAIL("Sequence (?#... not terminated");
2192                nextchar(pRExC_state);
2193                *flagp = TRYAGAIN;
2194                return NULL;
2195            case 'p':           /* (?p...) */
2196                if (SIZE_ONLY && ckWARN2(WARN_DEPRECATED, WARN_REGEXP))
2197                    vWARNdep(RExC_parse, "(?p{}) is deprecated - use (??{})");
2198                /* FALL THROUGH*/
2199            case '?':           /* (??...) */
2200                logical = 1;
2201                if (*RExC_parse != '{')
2202                    goto unknown;
2203                paren = *RExC_parse++;
2204                /* FALL THROUGH */
2205            case '{':           /* (?{...}) */
2206            {
2207                I32 count = 1, n = 0;
2208                char c;
2209                char *s = RExC_parse;
2210                SV *sv;
2211                OP_4tree *sop, *rop;
2212
2213                RExC_seen_zerolen++;
2214                RExC_seen |= REG_SEEN_EVAL;
2215                while (count && (c = *RExC_parse)) {
2216                    if (c == '\\' && RExC_parse[1])
2217                        RExC_parse++;
2218                    else if (c == '{')
2219                        count++;
2220                    else if (c == '}')
2221                        count--;
2222                    RExC_parse++;
2223                }
2224                if (*RExC_parse != ')')
2225                {
2226                    RExC_parse = s;             
2227                    vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
2228                }
2229                if (!SIZE_ONLY) {
2230                    PAD *pad;
2231               
2232                    if (RExC_parse - 1 - s)
2233                        sv = newSVpvn(s, RExC_parse - 1 - s);
2234                    else
2235                        sv = newSVpvn("", 0);
2236
2237                    ENTER;
2238                    Perl_save_re_context(aTHX);
2239                    rop = sv_compile_2op(sv, &sop, "re", &pad);
2240                    sop->op_private |= OPpREFCOUNTED;
2241                    /* re_dup will OpREFCNT_inc */
2242                    OpREFCNT_set(sop, 1);
2243                    LEAVE;
2244
2245                    n = add_data(pRExC_state, 3, "nop");
2246                    RExC_rx->data->data[n] = (void*)rop;
2247                    RExC_rx->data->data[n+1] = (void*)sop;
2248                    RExC_rx->data->data[n+2] = (void*)pad;
2249                    SvREFCNT_dec(sv);
2250                }
2251                else {                                          /* First pass */
2252                    if (PL_reginterp_cnt < ++RExC_seen_evals
2253                        && IN_PERL_RUNTIME)
2254                        /* No compiled RE interpolated, has runtime
2255                           components ===> unsafe.  */
2256                        FAIL("Eval-group not allowed at runtime, use re 'eval'");
2257                    if (PL_tainting && PL_tainted)
2258                        FAIL("Eval-group in insecure regular expression");
2259                }
2260               
2261                nextchar(pRExC_state);
2262                if (logical) {
2263                    ret = reg_node(pRExC_state, LOGICAL);
2264                    if (!SIZE_ONLY)
2265                        ret->flags = 2;
2266                    regtail(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
2267                    /* deal with the length of this later - MJD */
2268                    return ret;
2269                }
2270                ret = reganode(pRExC_state, EVAL, n);
2271                Set_Node_Length(ret, RExC_parse - parse_start + 1);
2272                Set_Node_Offset(ret, parse_start);
2273                return ret;
2274            }
2275            case '(':           /* (?(?{...})...) and (?(?=...)...) */
2276            {
2277                if (RExC_parse[0] == '?') {        /* (?(?...)) */
2278                    if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
2279                        || RExC_parse[1] == '<'
2280                        || RExC_parse[1] == '{') { /* Lookahead or eval. */
2281                        I32 flag;
2282                       
2283                        ret = reg_node(pRExC_state, LOGICAL);
2284                        if (!SIZE_ONLY)
2285                            ret->flags = 1;
2286                        regtail(pRExC_state, ret, reg(pRExC_state, 1, &flag));
2287                        goto insert_if;
2288                    }
2289                }
2290                else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
2291                    /* (?(1)...) */
2292                    parno = atoi(RExC_parse++);
2293
2294                    while (isDIGIT(*RExC_parse))
2295                        RExC_parse++;
2296                    ret = reganode(pRExC_state, GROUPP, parno);
2297                   
2298                    if ((c = *nextchar(pRExC_state)) != ')')
2299                        vFAIL("Switch condition not recognized");
2300                  insert_if:
2301                    regtail(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
2302                    br = regbranch(pRExC_state, &flags, 1);
2303                    if (br == NULL)
2304                        br = reganode(pRExC_state, LONGJMP, 0);
2305                    else
2306                        regtail(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
2307                    c = *nextchar(pRExC_state);
2308                    if (flags&HASWIDTH)
2309                        *flagp |= HASWIDTH;
2310                    if (c == '|') {
2311                        lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
2312                        regbranch(pRExC_state, &flags, 1);
2313                        regtail(pRExC_state, ret, lastbr);
2314                        if (flags&HASWIDTH)
2315                            *flagp |= HASWIDTH;
2316                        c = *nextchar(pRExC_state);
2317                    }
2318                    else
2319                        lastbr = NULL;
2320                    if (c != ')')
2321                        vFAIL("Switch (?(condition)... contains too many branches");
2322                    ender = reg_node(pRExC_state, TAIL);
2323                    regtail(pRExC_state, br, ender);
2324                    if (lastbr) {
2325                        regtail(pRExC_state, lastbr, ender);
2326                        regtail(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
2327                    }
2328                    else
2329                        regtail(pRExC_state, ret, ender);
2330                    return ret;
2331                }
2332                else {
2333                    vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
2334                }
2335            }
2336            case 0:
2337                RExC_parse--; /* for vFAIL to print correctly */
2338                vFAIL("Sequence (? incomplete");
2339                break;
2340            default:
2341                --RExC_parse;
2342              parse_flags:      /* (?i) */
2343                while (*RExC_parse && strchr("iogcmsx", *RExC_parse)) {
2344                    /* (?g), (?gc) and (?o) are useless here
2345                       and must be globally applied -- japhy */
2346
2347                    if (*RExC_parse == 'o' || *RExC_parse == 'g') {
2348                        if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
2349                            I32 wflagbit = *RExC_parse == 'o' ? wasted_o : wasted_g;
2350                            if (! (wastedflags & wflagbit) ) {
2351                                wastedflags |= wflagbit;
2352                                vWARN5(
2353                                    RExC_parse + 1,
2354                                    "Useless (%s%c) - %suse /%c modifier",
2355                                    flagsp == &negflags ? "?-" : "?",
2356                                    *RExC_parse,
2357                                    flagsp == &negflags ? "don't " : "",
2358                                    *RExC_parse
2359                                );
2360                            }
2361                        }
2362                    }
2363                    else if (*RExC_parse == 'c') {
2364                        if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
2365                            if (! (wastedflags & wasted_c) ) {
2366                                wastedflags |= wasted_gc;
2367                                vWARN3(
2368                                    RExC_parse + 1,
2369                                    "Useless (%sc) - %suse /gc modifier",
2370                                    flagsp == &negflags ? "?-" : "?",
2371                                    flagsp == &negflags ? "don't " : ""
2372                                );
2373                            }
2374                        }
2375                    }
2376                    else { pmflag(flagsp, *RExC_parse); }
2377
2378                    ++RExC_parse;
2379                }
2380                if (*RExC_parse == '-') {
2381                    flagsp = &negflags;
2382                    wastedflags = 0;  /* reset so (?g-c) warns twice */
2383                    ++RExC_parse;
2384                    goto parse_flags;
2385                }
2386                RExC_flags |= posflags;
2387                RExC_flags &= ~negflags;
2388                if (*RExC_parse == ':') {
2389                    RExC_parse++;
2390                    paren = ':';
2391                    break;
2392                }               
2393              unknown:
2394                if (*RExC_parse != ')') {
2395                    RExC_parse++;
2396                    vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
2397                }
2398                nextchar(pRExC_state);
2399                *flagp = TRYAGAIN;
2400                return NULL;
2401            }
2402        }
2403        else {                  /* (...) */
2404            parno = RExC_npar;
2405            RExC_npar++;
2406            ret = reganode(pRExC_state, OPEN, parno);
2407            Set_Node_Length(ret, 1); /* MJD */
2408            Set_Node_Offset(ret, RExC_parse); /* MJD */
2409            open = 1;
2410        }
2411    }
2412    else                        /* ! paren */
2413        ret = NULL;
2414
2415    /* Pick up the branches, linking them together. */
2416    parse_start = RExC_parse;   /* MJD */
2417    br = regbranch(pRExC_state, &flags, 1);
2418    /*     branch_len = (paren != 0); */
2419   
2420    if (br == NULL)
2421        return(NULL);
2422    if (*RExC_parse == '|') {
2423        if (!SIZE_ONLY && RExC_extralen) {
2424            reginsert(pRExC_state, BRANCHJ, br);
2425        }
2426        else {                  /* MJD */
2427            reginsert(pRExC_state, BRANCH, br);
2428            Set_Node_Length(br, paren != 0);
2429            Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
2430        }
2431        have_branch = 1;
2432        if (SIZE_ONLY)
2433            RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
2434    }
2435    else if (paren == ':') {
2436        *flagp |= flags&SIMPLE;
2437    }
2438    if (open) {                         /* Starts with OPEN. */
2439        regtail(pRExC_state, ret, br);          /* OPEN -> first. */
2440    }
2441    else if (paren != '?')              /* Not Conditional */
2442        ret = br;
2443    *flagp |= flags & (SPSTART | HASWIDTH);
2444    lastbr = br;
2445    while (*RExC_parse == '|') {
2446        if (!SIZE_ONLY && RExC_extralen) {
2447            ender = reganode(pRExC_state, LONGJMP,0);
2448            regtail(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
2449        }
2450        if (SIZE_ONLY)
2451            RExC_extralen += 2;         /* Account for LONGJMP. */
2452        nextchar(pRExC_state);
2453        br = regbranch(pRExC_state, &flags, 0);
2454       
2455        if (br == NULL)
2456            return(NULL);
2457        regtail(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
2458        lastbr = br;
2459        if (flags&HASWIDTH)
2460            *flagp |= HASWIDTH;
2461        *flagp |= flags&SPSTART;
2462    }
2463
2464    if (have_branch || paren != ':') {
2465        /* Make a closing node, and hook it on the end. */
2466        switch (paren) {
2467        case ':':
2468            ender = reg_node(pRExC_state, TAIL);
2469            break;
2470        case 1:
2471            ender = reganode(pRExC_state, CLOSE, parno);
2472            Set_Node_Offset(ender,RExC_parse+1); /* MJD */
2473            Set_Node_Length(ender,1); /* MJD */
2474            break;
2475        case '<':
2476        case ',':
2477        case '=':
2478        case '!':
2479            *flagp &= ~HASWIDTH;
2480            /* FALL THROUGH */
2481        case '>':
2482            ender = reg_node(pRExC_state, SUCCEED);
2483            break;
2484        case 0:
2485            ender = reg_node(pRExC_state, END);
2486            break;
2487        }
2488        regtail(pRExC_state, lastbr, ender);
2489
2490        if (have_branch) {
2491            /* Hook the tails of the branches to the closing node. */
2492            for (br = ret; br != NULL; br = regnext(br)) {
2493                regoptail(pRExC_state, br, ender);
2494            }
2495        }
2496    }
2497
2498    {
2499        char *p;
2500        static char parens[] = "=!<,>";
2501
2502        if (paren && (p = strchr(parens, paren))) {
2503            U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
2504            int flag = (p - parens) > 1;
2505
2506            if (paren == '>')
2507                node = SUSPEND, flag = 0;
2508            reginsert(pRExC_state, node,ret);
2509            Set_Node_Cur_Length(ret);
2510            Set_Node_Offset(ret, parse_start + 1);
2511            ret->flags = flag;
2512            regtail(pRExC_state, ret, reg_node(pRExC_state, TAIL));
2513        }
2514    }
2515
2516    /* Check for proper termination. */
2517    if (paren) {
2518        RExC_flags = oregflags;
2519        if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
2520            RExC_parse = oregcomp_parse;
2521            vFAIL("Unmatched (");
2522        }
2523    }
2524    else if (!paren && RExC_parse < RExC_end) {
2525        if (*RExC_parse == ')') {
2526            RExC_parse++;
2527            vFAIL("Unmatched )");
2528        }
2529        else
2530            FAIL("Junk on end of regexp");      /* "Can't happen". */
2531        /* NOTREACHED */
2532    }
2533
2534    return(ret);
2535}
2536
2537/*
2538 - regbranch - one alternative of an | operator
2539 *
2540 * Implements the concatenation operator.
2541 */
2542STATIC regnode *
2543S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first)
2544{
2545    register regnode *ret;
2546    register regnode *chain = NULL;
2547    register regnode *latest;
2548    I32 flags = 0, c = 0;
2549
2550    if (first)
2551        ret = NULL;
2552    else {
2553        if (!SIZE_ONLY && RExC_extralen)
2554            ret = reganode(pRExC_state, BRANCHJ,0);
2555        else {
2556            ret = reg_node(pRExC_state, BRANCH);
2557            Set_Node_Length(ret, 1);
2558        }
2559    }
2560       
2561    if (!first && SIZE_ONLY)
2562        RExC_extralen += 1;                     /* BRANCHJ */
2563
2564    *flagp = WORST;                     /* Tentatively. */
2565
2566    RExC_parse--;
2567    nextchar(pRExC_state);
2568    while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
2569        flags &= ~TRYAGAIN;
2570        latest = regpiece(pRExC_state, &flags);
2571        if (latest == NULL) {
2572            if (flags & TRYAGAIN)
2573                continue;
2574            return(NULL);
2575        }
2576        else if (ret == NULL)
2577            ret = latest;
2578        *flagp |= flags&HASWIDTH;
2579        if (chain == NULL)      /* First piece. */
2580            *flagp |= flags&SPSTART;
2581        else {
2582            RExC_naughty++;
2583            regtail(pRExC_state, chain, latest);
2584        }
2585        chain = latest;
2586        c++;
2587    }
2588    if (chain == NULL) {        /* Loop ran zero times. */
2589        chain = reg_node(pRExC_state, NOTHING);
2590        if (ret == NULL)
2591            ret = chain;
2592    }
2593    if (c == 1) {
2594        *flagp |= flags&SIMPLE;
2595    }
2596
2597    return(ret);
2598}
2599
2600/*
2601 - regpiece - something followed by possible [*+?]
2602 *
2603 * Note that the branching code sequences used for ? and the general cases
2604 * of * and + are somewhat optimized:  they use the same NOTHING node as
2605 * both the endmarker for their branch list and the body of the last branch.
2606 * It might seem that this node could be dispensed with entirely, but the
2607 * endmarker role is not redundant.
2608 */
2609STATIC regnode *
2610S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp)
2611{
2612    register regnode *ret;
2613    register char op;
2614    register char *next;
2615    I32 flags;
2616    char *origparse = RExC_parse;
2617    char *maxpos;
2618    I32 min;
2619    I32 max = REG_INFTY;
2620    char *parse_start;
2621
2622    ret = regatom(pRExC_state, &flags);
2623    if (ret == NULL) {
2624        if (flags & TRYAGAIN)
2625            *flagp |= TRYAGAIN;
2626        return(NULL);
2627    }
2628
2629    op = *RExC_parse;
2630
2631    if (op == '{' && regcurly(RExC_parse)) {
2632        parse_start = RExC_parse; /* MJD */
2633        next = RExC_parse + 1;
2634        maxpos = Nullch;
2635        while (isDIGIT(*next) || *next == ',') {
2636            if (*next == ',') {
2637                if (maxpos)
2638                    break;
2639                else
2640                    maxpos = next;
2641            }
2642            next++;
2643        }
2644        if (*next == '}') {             /* got one */
2645            if (!maxpos)
2646                maxpos = next;
2647            RExC_parse++;
2648            min = atoi(RExC_parse);
2649            if (*maxpos == ',')
2650                maxpos++;
2651            else
2652                maxpos = RExC_parse;
2653            max = atoi(maxpos);
2654            if (!max && *maxpos != '0')
2655                max = REG_INFTY;                /* meaning "infinity" */
2656            else if (max >= REG_INFTY)
2657                vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
2658            RExC_parse = next;
2659            nextchar(pRExC_state);
2660
2661        do_curly:
2662            if ((flags&SIMPLE)) {
2663                RExC_naughty += 2 + RExC_naughty / 2;
2664                reginsert(pRExC_state, CURLY, ret);
2665                Set_Node_Offset(ret, parse_start+1); /* MJD */
2666                Set_Node_Cur_Length(ret);
2667            }
2668            else {
2669                regnode *w = reg_node(pRExC_state, WHILEM);
2670
2671                w->flags = 0;
2672                regtail(pRExC_state, ret, w);
2673                if (!SIZE_ONLY && RExC_extralen) {
2674                    reginsert(pRExC_state, LONGJMP,ret);
2675                    reginsert(pRExC_state, NOTHING,ret);
2676                    NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
2677                }
2678                reginsert(pRExC_state, CURLYX,ret);
2679                                /* MJD hk */
2680                Set_Node_Offset(ret, parse_start+1);
2681                Set_Node_Length(ret,
2682                                op == '{' ? (RExC_parse - parse_start) : 1);
2683               
2684                if (!SIZE_ONLY && RExC_extralen)
2685                    NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
2686                regtail(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
2687                if (SIZE_ONLY)
2688                    RExC_whilem_seen++, RExC_extralen += 3;
2689                RExC_naughty += 4 + RExC_naughty;       /* compound interest */
2690            }
2691            ret->flags = 0;
2692
2693            if (min > 0)
2694                *flagp = WORST;
2695            if (max > 0)
2696                *flagp |= HASWIDTH;
2697            if (max && max < min)
2698                vFAIL("Can't do {n,m} with n > m");
2699            if (!SIZE_ONLY) {
2700                ARG1_SET(ret, (U16)min);
2701                ARG2_SET(ret, (U16)max);
2702            }
2703
2704            goto nest_check;
2705        }
2706    }
2707
2708    if (!ISMULT1(op)) {
2709        *flagp = flags;
2710        return(ret);
2711    }
2712
2713#if 0                           /* Now runtime fix should be reliable. */
2714
2715    /* if this is reinstated, don't forget to put this back into perldiag:
2716
2717            =item Regexp *+ operand could be empty at {#} in regex m/%s/
2718
2719           (F) The part of the regexp subject to either the * or + quantifier
2720           could match an empty string. The {#} shows in the regular
2721           expression about where the problem was discovered.
2722
2723    */
2724
2725    if (!(flags&HASWIDTH) && op != '?')
2726      vFAIL("Regexp *+ operand could be empty");
2727#endif
2728
2729    parse_start = RExC_parse;
2730    nextchar(pRExC_state);
2731
2732    *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
2733
2734    if (op == '*' && (flags&SIMPLE)) {
2735        reginsert(pRExC_state, STAR, ret);
2736        ret->flags = 0;
2737        RExC_naughty += 4;
2738    }
2739    else if (op == '*') {
2740        min = 0;
2741        goto do_curly;
2742    }
2743    else if (op == '+' && (flags&SIMPLE)) {
2744        reginsert(pRExC_state, PLUS, ret);
2745        ret->flags = 0;
2746        RExC_naughty += 3;
2747    }
2748    else if (op == '+') {
2749        min = 1;
2750        goto do_curly;
2751    }
2752    else if (op == '?') {
2753        min = 0; max = 1;
2754        goto do_curly;
2755    }
2756  nest_check:
2757    if (ckWARN(WARN_REGEXP) && !SIZE_ONLY && !(flags&HASWIDTH) && max > REG_INFTY/3) {
2758        vWARN3(RExC_parse,
2759               "%.*s matches null string many times",
2760               RExC_parse - origparse,
2761               origparse);
2762    }
2763
2764    if (*RExC_parse == '?') {
2765        nextchar(pRExC_state);
2766        reginsert(pRExC_state, MINMOD, ret);
2767        regtail(pRExC_state, ret, ret + NODE_STEP_REGNODE);
2768    }
2769    if (ISMULT2(RExC_parse)) {
2770        RExC_parse++;
2771        vFAIL("Nested quantifiers");
2772    }
2773
2774    return(ret);
2775}
2776
2777/*
2778 - regatom - the lowest level
2779 *
2780 * Optimization:  gobbles an entire sequence of ordinary characters so that
2781 * it can turn them into a single node, which is smaller to store and
2782 * faster to run.  Backslashed characters are exceptions, each becoming a
2783 * separate node; the code is simpler that way and it's not worth fixing.
2784 *
2785 * [Yes, it is worth fixing, some scripts can run twice the speed.] */
2786STATIC regnode *
2787S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp)
2788{
2789    register regnode *ret = 0;
2790    I32 flags;
2791    char *parse_start = RExC_parse;
2792
2793    *flagp = WORST;             /* Tentatively. */
2794
2795tryagain:
2796    switch (*RExC_parse) {
2797    case '^':
2798        RExC_seen_zerolen++;
2799        nextchar(pRExC_state);
2800        if (RExC_flags & PMf_MULTILINE)
2801            ret = reg_node(pRExC_state, MBOL);
2802        else if (RExC_flags & PMf_SINGLELINE)
2803            ret = reg_node(pRExC_state, SBOL);
2804        else
2805            ret = reg_node(pRExC_state, BOL);
2806        Set_Node_Length(ret, 1); /* MJD */
2807        break;
2808    case '$':
2809        nextchar(pRExC_state);
2810        if (*RExC_parse)
2811            RExC_seen_zerolen++;
2812        if (RExC_flags & PMf_MULTILINE)
2813            ret = reg_node(pRExC_state, MEOL);
2814        else if (RExC_flags & PMf_SINGLELINE)
2815            ret = reg_node(pRExC_state, SEOL);
2816        else
2817            ret = reg_node(pRExC_state, EOL);
2818        Set_Node_Length(ret, 1); /* MJD */
2819        break;
2820    case '.':
2821        nextchar(pRExC_state);
2822        if (RExC_flags & PMf_SINGLELINE)
2823            ret = reg_node(pRExC_state, SANY);
2824        else
2825            ret = reg_node(pRExC_state, REG_ANY);
2826        *flagp |= HASWIDTH|SIMPLE;
2827        RExC_naughty++;
2828        Set_Node_Length(ret, 1); /* MJD */
2829        break;
2830    case '[':
2831    {
2832        char *oregcomp_parse = ++RExC_parse;
2833        ret = regclass(pRExC_state);
2834        if (*RExC_parse != ']') {
2835            RExC_parse = oregcomp_parse;
2836            vFAIL("Unmatched [");
2837        }
2838        nextchar(pRExC_state);
2839        *flagp |= HASWIDTH|SIMPLE;
2840        Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
2841        break;
2842    }
2843    case '(':
2844        nextchar(pRExC_state);
2845        ret = reg(pRExC_state, 1, &flags);
2846        if (ret == NULL) {
2847                if (flags & TRYAGAIN) {
2848                    if (RExC_parse == RExC_end) {
2849                         /* Make parent create an empty node if needed. */
2850                        *flagp |= TRYAGAIN;
2851                        return(NULL);
2852                    }
2853                    goto tryagain;
2854                }
2855                return(NULL);
2856        }
2857        *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE);
2858        break;
2859    case '|':
2860    case ')':
2861        if (flags & TRYAGAIN) {
2862            *flagp |= TRYAGAIN;
2863            return NULL;
2864        }
2865        vFAIL("Internal urp");
2866                                /* Supposed to be caught earlier. */
2867        break;
2868    case '{':
2869        if (!regcurly(RExC_parse)) {
2870            RExC_parse++;
2871            goto defchar;
2872        }
2873        /* FALL THROUGH */
2874    case '?':
2875    case '+':
2876    case '*':
2877        RExC_parse++;
2878        vFAIL("Quantifier follows nothing");
2879        break;
2880    case '\\':
2881        switch (*++RExC_parse) {
2882        case 'A':
2883            RExC_seen_zerolen++;
2884            ret = reg_node(pRExC_state, SBOL);
2885            *flagp |= SIMPLE;
2886            nextchar(pRExC_state);
2887            Set_Node_Length(ret, 2); /* MJD */
2888            break;
2889        case 'G':
2890            ret = reg_node(pRExC_state, GPOS);
2891            RExC_seen |= REG_SEEN_GPOS;
2892            *flagp |= SIMPLE;
2893            nextchar(pRExC_state);
2894            Set_Node_Length(ret, 2); /* MJD */
2895            break;
2896        case 'Z':
2897            ret = reg_node(pRExC_state, SEOL);
2898            *flagp |= SIMPLE;
2899            RExC_seen_zerolen++;                /* Do not optimize RE away */
2900            nextchar(pRExC_state);
2901            break;
2902        case 'z':
2903            ret = reg_node(pRExC_state, EOS);
2904            *flagp |= SIMPLE;
2905            RExC_seen_zerolen++;                /* Do not optimize RE away */
2906            nextchar(pRExC_state);
2907            Set_Node_Length(ret, 2); /* MJD */
2908            break;
2909        case 'C':
2910            ret = reg_node(pRExC_state, CANY);
2911            RExC_seen |= REG_SEEN_CANY;
2912            *flagp |= HASWIDTH|SIMPLE;
2913            nextchar(pRExC_state);
2914            Set_Node_Length(ret, 2); /* MJD */
2915            break;
2916        case 'X':
2917            ret = reg_node(pRExC_state, CLUMP);
2918            *flagp |= HASWIDTH;
2919            nextchar(pRExC_state);
2920            Set_Node_Length(ret, 2); /* MJD */
2921            break;
2922        case 'w':
2923            ret = reg_node(pRExC_state, (U8)(LOC ? ALNUML     : ALNUM));
2924            *flagp |= HASWIDTH|SIMPLE;
2925            nextchar(pRExC_state);
2926            Set_Node_Length(ret, 2); /* MJD */
2927            break;
2928        case 'W':
2929            ret = reg_node(pRExC_state, (U8)(LOC ? NALNUML    : NALNUM));
2930            *flagp |= HASWIDTH|SIMPLE;
2931            nextchar(pRExC_state);
2932            Set_Node_Length(ret, 2); /* MJD */
2933            break;
2934        case 'b':
2935            RExC_seen_zerolen++;
2936            RExC_seen |= REG_SEEN_LOOKBEHIND;
2937            ret = reg_node(pRExC_state, (U8)(LOC ? BOUNDL     : BOUND));
2938            *flagp |= SIMPLE;
2939            nextchar(pRExC_state);
2940            Set_Node_Length(ret, 2); /* MJD */
2941            break;
2942        case 'B':
2943            RExC_seen_zerolen++;
2944            RExC_seen |= REG_SEEN_LOOKBEHIND;
2945            ret = reg_node(pRExC_state, (U8)(LOC ? NBOUNDL    : NBOUND));
2946            *flagp |= SIMPLE;
2947            nextchar(pRExC_state);
2948            Set_Node_Length(ret, 2); /* MJD */
2949            break;
2950        case 's':
2951            ret = reg_node(pRExC_state, (U8)(LOC ? SPACEL     : SPACE));
2952            *flagp |= HASWIDTH|SIMPLE;
2953            nextchar(pRExC_state);
2954            Set_Node_Length(ret, 2); /* MJD */
2955            break;
2956        case 'S':
2957            ret = reg_node(pRExC_state, (U8)(LOC ? NSPACEL    : NSPACE));
2958            *flagp |= HASWIDTH|SIMPLE;
2959            nextchar(pRExC_state);
2960            Set_Node_Length(ret, 2); /* MJD */
2961            break;
2962        case 'd':
2963            ret = reg_node(pRExC_state, DIGIT);
2964            *flagp |= HASWIDTH|SIMPLE;
2965            nextchar(pRExC_state);
2966            Set_Node_Length(ret, 2); /* MJD */
2967            break;
2968        case 'D':
2969            ret = reg_node(pRExC_state, NDIGIT);
2970            *flagp |= HASWIDTH|SIMPLE;
2971            nextchar(pRExC_state);
2972            Set_Node_Length(ret, 2); /* MJD */
2973            break;
2974        case 'p':
2975        case 'P':
2976            {   
2977                char* oldregxend = RExC_end;
2978                char* parse_start = RExC_parse - 2;
2979
2980                if (RExC_parse[1] == '{') {
2981                  /* a lovely hack--pretend we saw [\pX] instead */
2982                    RExC_end = strchr(RExC_parse, '}');
2983                    if (!RExC_end) {
2984                        U8 c = (U8)*RExC_parse;
2985                        RExC_parse += 2;
2986                        RExC_end = oldregxend;
2987                        vFAIL2("Missing right brace on \\%c{}", c);
2988                    }
2989                    RExC_end++;
2990                }
2991                else {
2992                    RExC_end = RExC_parse + 2;
2993                    if (RExC_end > oldregxend)
2994                        RExC_end = oldregxend;
2995                }
2996                RExC_parse--;
2997
2998                ret = regclass(pRExC_state);
2999
3000                RExC_end = oldregxend;
3001                RExC_parse--;
3002
3003                Set_Node_Offset(ret, parse_start + 2);
3004                Set_Node_Cur_Length(ret);
3005                nextchar(pRExC_state);
3006                *flagp |= HASWIDTH|SIMPLE;
3007            }
3008            break;
3009        case 'n':
3010        case 'r':
3011        case 't':
3012        case 'f':
3013        case 'e':
3014        case 'a':
3015        case 'x':
3016        case 'c':
3017        case '0':
3018            goto defchar;
3019        case '1': case '2': case '3': case '4':
3020        case '5': case '6': case '7': case '8': case '9':
3021            {
3022                I32 num = atoi(RExC_parse);
3023
3024                if (num > 9 && num >= RExC_npar)
3025                    goto defchar;
3026                else {
3027                    char * parse_start = RExC_parse - 1; /* MJD */
3028                    while (isDIGIT(*RExC_parse))
3029                        RExC_parse++;
3030
3031                    if (!SIZE_ONLY && num > (I32)RExC_rx->nparens)
3032                        vFAIL("Reference to nonexistent group");
3033                    RExC_sawback = 1;
3034                    ret = reganode(pRExC_state,
3035                                   (U8)(FOLD ? (LOC ? REFFL : REFF) : REF),
3036                                   num);
3037                    *flagp |= HASWIDTH;
3038                   
3039                    /* override incorrect value set in reganode MJD */
3040                    Set_Node_Offset(ret, parse_start+1);
3041                    Set_Node_Cur_Length(ret); /* MJD */
3042                    RExC_parse--;
3043                    nextchar(pRExC_state);
3044                }
3045            }
3046            break;
3047        case '\0':
3048            if (RExC_parse >= RExC_end)
3049                FAIL("Trailing \\");
3050            /* FALL THROUGH */
3051        default:
3052            /* Do not generate `unrecognized' warnings here, we fall
3053               back into the quick-grab loop below */
3054            parse_start--;
3055            goto defchar;
3056        }
3057        break;
3058
3059    case '#':
3060        if (RExC_flags & PMf_EXTENDED) {
3061            while (RExC_parse < RExC_end && *RExC_parse != '\n') RExC_parse++;
3062            if (RExC_parse < RExC_end)
3063                goto tryagain;
3064        }
3065        /* FALL THROUGH */
3066
3067    default: {
3068            register STRLEN len;
3069            register UV ender;
3070            register char *p;
3071            char *oldp, *s;
3072            STRLEN numlen;
3073            STRLEN foldlen;
3074            U8 tmpbuf[UTF8_MAXLEN_FOLD+1], *foldbuf;
3075
3076            parse_start = RExC_parse - 1;
3077
3078            RExC_parse++;
3079
3080        defchar:
3081            ender = 0;
3082            ret = reg_node(pRExC_state,
3083                           (U8)(FOLD ? (LOC ? EXACTFL : EXACTF) : EXACT));
3084            s = STRING(ret);
3085            for (len = 0, p = RExC_parse - 1;
3086              len < 127 && p < RExC_end;
3087              len++)
3088            {
3089                oldp = p;
3090
3091                if (RExC_flags & PMf_EXTENDED)
3092                    p = regwhite(p, RExC_end);
3093                switch (*p) {
3094                case '^':
3095                case '$':
3096                case '.':
3097                case '[':
3098                case '(':
3099                case ')':
3100                case '|':
3101                    goto loopdone;
3102                case '\\':
3103                    switch (*++p) {
3104                    case 'A':
3105                    case 'C':
3106                    case 'X':
3107                    case 'G':
3108                    case 'Z':
3109                    case 'z':
3110                    case 'w':
3111                    case 'W':
3112                    case 'b':
3113                    case 'B':
3114                    case 's':
3115                    case 'S':
3116                    case 'd':
3117                    case 'D':
3118                    case 'p':
3119                    case 'P':
3120                        --p;
3121                        goto loopdone;
3122                    case 'n':
3123                        ender = '\n';
3124                        p++;
3125                        break;
3126                    case 'r':
3127                        ender = '\r';
3128                        p++;
3129                        break;
3130                    case 't':
3131                        ender = '\t';
3132                        p++;
3133                        break;
3134                    case 'f':
3135                        ender = '\f';
3136                        p++;
3137                        break;
3138                    case 'e':
3139                          ender = ASCII_TO_NATIVE('\033');
3140                        p++;
3141                        break;
3142                    case 'a':
3143                          ender = ASCII_TO_NATIVE('\007');
3144                        p++;
3145                        break;
3146                    case 'x':
3147                        if (*++p == '{') {
3148                            char* e = strchr(p, '}');
3149       
3150                            if (!e) {
3151                                RExC_parse = p + 1;
3152                                vFAIL("Missing right brace on \\x{}");
3153                            }
3154                            else {
3155                                I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3156                                    | PERL_SCAN_DISALLOW_PREFIX;
3157                                numlen = e - p - 1;
3158                                ender = grok_hex(p + 1, &numlen, &flags, NULL);
3159                                if (ender > 0xff)
3160                                    RExC_utf8 = 1;
3161                                p = e + 1;
3162                            }
3163                        }
3164                        else {
3165                            I32 flags = PERL_SCAN_DISALLOW_PREFIX;
3166                            numlen = 2;
3167                            ender = grok_hex(p, &numlen, &flags, NULL);
3168                            p += numlen;
3169                        }
3170                        break;
3171                    case 'c':
3172                        p++;
3173                        ender = UCHARAT(p++);
3174                        ender = toCTRL(ender);
3175                        break;
3176                    case '0': case '1': case '2': case '3':case '4':
3177                    case '5': case '6': case '7': case '8':case '9':
3178                        if (*p == '0' ||
3179                          (isDIGIT(p[1]) && atoi(p) >= RExC_npar) ) {
3180                            I32 flags = 0;
3181                            numlen = 3;
3182                            ender = grok_oct(p, &numlen, &flags, NULL);
3183                            p += numlen;
3184                        }
3185                        else {
3186                            --p;
3187                            goto loopdone;
3188                        }
3189                        break;
3190                    case '\0':
3191                        if (p >= RExC_end)
3192                            FAIL("Trailing \\");
3193                        /* FALL THROUGH */
3194                    default:
3195                        if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && isALPHA(*p))
3196                            vWARN2(p + 1, "Unrecognized escape \\%c passed through", UCHARAT(p));
3197                        goto normal_default;
3198                    }
3199                    break;
3200                default:
3201                  normal_default:
3202                    if (UTF8_IS_START(*p) && UTF) {
3203                        ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
3204                                               &numlen, 0);
3205                        p += numlen;
3206                    }
3207                    else
3208                        ender = *p++;
3209                    break;
3210                }
3211                if (RExC_flags & PMf_EXTENDED)
3212                    p = regwhite(p, RExC_end);
3213                if (UTF && FOLD) {
3214                    /* Prime the casefolded buffer. */
3215                    ender = toFOLD_uni(ender, tmpbuf, &foldlen);
3216                }
3217                if (ISMULT2(p)) { /* Back off on ?+*. */
3218                    if (len)
3219                        p = oldp;
3220                    else if (UTF) {
3221                         STRLEN unilen;
3222
3223                         if (FOLD) {
3224                              /* Emit all the Unicode characters. */
3225                              for (foldbuf = tmpbuf;
3226                                   foldlen;
3227                                   foldlen -= numlen) {
3228                                   ender = utf8_to_uvchr(foldbuf, &numlen);
3229                                   if (numlen > 0) {
3230                                        reguni(pRExC_state, ender, s, &unilen);
3231                                        s       += unilen;
3232                                        len     += unilen;
3233                                        /* In EBCDIC the numlen
3234                                         * and unilen can differ. */
3235                                        foldbuf += numlen;
3236                                        if (numlen >= foldlen)
3237                                             break;
3238                                   }
3239                                   else
3240                                        break; /* "Can't happen." */
3241                              }
3242                         }
3243                         else {
3244                              reguni(pRExC_state, ender, s, &unilen);
3245                              if (unilen > 0) {
3246                                   s   += unilen;
3247                                   len += unilen;
3248                              }
3249                         }
3250                    }
3251                    else {
3252                        len++;
3253                        REGC((char)ender, s++);
3254                    }
3255                    break;
3256                }
3257                if (UTF) {
3258                     STRLEN unilen;
3259
3260                     if (FOLD) {
3261                          /* Emit all the Unicode characters. */
3262                          for (foldbuf = tmpbuf;
3263                               foldlen;
3264                               foldlen -= numlen) {
3265                               ender = utf8_to_uvchr(foldbuf, &numlen);
3266                               if (numlen > 0) {
3267                                    reguni(pRExC_state, ender, s, &unilen);
3268                                    len     += unilen;
3269                                    s       += unilen;
3270                                    /* In EBCDIC the numlen
3271                                     * and unilen can differ. */
3272                                    foldbuf += numlen;
3273                                    if (numlen >= foldlen)
3274                                         break;
3275                               }
3276                               else
3277                                    break;
3278                          }
3279                     }
3280                     else {
3281                          reguni(pRExC_state, ender, s, &unilen);
3282                          if (unilen > 0) {
3283                               s   += unilen;
3284                               len += unilen;
3285                          }
3286                     }
3287                     len--;
3288                }
3289                else
3290                    REGC((char)ender, s++);
3291            }
3292        loopdone:
3293            RExC_parse = p - 1;
3294            Set_Node_Cur_Length(ret); /* MJD */
3295            nextchar(pRExC_state);
3296            {
3297                /* len is STRLEN which is unsigned, need to copy to signed */
3298                IV iv = len;
3299                if (iv < 0)
3300                    vFAIL("Internal disaster");
3301            }
3302            if (len > 0)
3303                *flagp |= HASWIDTH;
3304            if (len == 1 && UNI_IS_INVARIANT(ender))
3305                *flagp |= SIMPLE;
3306            if (!SIZE_ONLY)
3307                STR_LEN(ret) = len;
3308            if (SIZE_ONLY)
3309                RExC_size += STR_SZ(len);
3310            else
3311                RExC_emit += STR_SZ(len);
3312        }
3313        break;
3314    }
3315
3316    /* If the encoding pragma is in effect recode the text of
3317     * any EXACT-kind nodes. */
3318    if (PL_encoding && PL_regkind[(U8)OP(ret)] == EXACT) {
3319        STRLEN oldlen = STR_LEN(ret);
3320        SV *sv        = sv_2mortal(newSVpvn(STRING(ret), oldlen));
3321
3322        if (RExC_utf8)
3323            SvUTF8_on(sv);
3324        if (sv_utf8_downgrade(sv, TRUE)) {
3325            char *s       = sv_recode_to_utf8(sv, PL_encoding);
3326            STRLEN newlen = SvCUR(sv);
3327
3328            if (SvUTF8(sv))
3329                RExC_utf8 = 1;
3330            if (!SIZE_ONLY) {
3331                DEBUG_r(PerlIO_printf(Perl_debug_log, "recode %*s to %*s\n",
3332                                      (int)oldlen, STRING(ret),
3333                                      (int)newlen, s));
3334                Copy(s, STRING(ret), newlen, char);
3335                STR_LEN(ret) += newlen - oldlen;
3336                RExC_emit += STR_SZ(newlen) - STR_SZ(oldlen);
3337            } else
3338                RExC_size += STR_SZ(newlen) - STR_SZ(oldlen);
3339        }
3340    }
3341
3342    return(ret);
3343}
3344
3345STATIC char *
3346S_regwhite(pTHX_ char *p, char *e)
3347{
3348    while (p < e) {
3349        if (isSPACE(*p))
3350            ++p;
3351        else if (*p == '#') {
3352            do {
3353                p++;
3354            } while (p < e && *p != '\n');
3355        }
3356        else
3357            break;
3358    }
3359    return p;
3360}
3361
3362/* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
3363   Character classes ([:foo:]) can also be negated ([:^foo:]).
3364   Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
3365   Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
3366   but trigger failures because they are currently unimplemented. */
3367
3368#define POSIXCC_DONE(c)   ((c) == ':')
3369#define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
3370#define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
3371
3372STATIC I32
3373S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
3374{
3375    char *posixcc = 0;
3376    I32 namedclass = OOB_NAMEDCLASS;
3377
3378    if (value == '[' && RExC_parse + 1 < RExC_end &&
3379        /* I smell either [: or [= or [. -- POSIX has been here, right? */
3380        POSIXCC(UCHARAT(RExC_parse))) {
3381        char  c = UCHARAT(RExC_parse);
3382        char* s = RExC_parse++;
3383       
3384        while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
3385            RExC_parse++;
3386        if (RExC_parse == RExC_end)
3387            /* Grandfather lone [:, [=, [. */
3388            RExC_parse = s;
3389        else {
3390            char* t = RExC_parse++; /* skip over the c */
3391
3392            if (UCHARAT(RExC_parse) == ']') {
3393                RExC_parse++; /* skip over the ending ] */
3394                posixcc = s + 1;
3395                if (*s == ':') {
3396                    I32 complement = *posixcc == '^' ? *posixcc++ : 0;
3397                    I32 skip = 5; /* the most common skip */
3398
3399                    switch (*posixcc) {
3400                    case 'a':
3401                        if (strnEQ(posixcc, "alnum", 5))
3402                            namedclass =
3403                                complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
3404                        else if (strnEQ(posixcc, "alpha", 5))
3405                            namedclass =
3406                                complement ? ANYOF_NALPHA : ANYOF_ALPHA;
3407                        else if (strnEQ(posixcc, "ascii", 5))
3408                            namedclass =
3409                                complement ? ANYOF_NASCII : ANYOF_ASCII;
3410                        break;
3411                    case 'b':
3412                        if (strnEQ(posixcc, "blank", 5))
3413                            namedclass =
3414                                complement ? ANYOF_NBLANK : ANYOF_BLANK;
3415                        break;
3416                    case 'c':
3417                        if (strnEQ(posixcc, "cntrl", 5))
3418                            namedclass =
3419                                complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
3420                        break;
3421                    case 'd':
3422                        if (strnEQ(posixcc, "digit", 5))
3423                            namedclass =
3424                                complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
3425                        break;
3426                    case 'g':
3427                        if (strnEQ(posixcc, "graph", 5))
3428                            namedclass =
3429                                complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
3430                        break;
3431                    case 'l':
3432                        if (strnEQ(posixcc, "lower", 5))
3433                            namedclass =
3434                                complement ? ANYOF_NLOWER : ANYOF_LOWER;
3435                        break;
3436                    case 'p':
3437                        if (strnEQ(posixcc, "print", 5))
3438                            namedclass =
3439                                complement ? ANYOF_NPRINT : ANYOF_PRINT;
3440                        else if (strnEQ(posixcc, "punct", 5))
3441                            namedclass =
3442                                complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
3443                        break;
3444                    case 's':
3445                        if (strnEQ(posixcc, "space", 5))
3446                            namedclass =
3447                                complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
3448                        break;
3449                    case 'u':
3450                        if (strnEQ(posixcc, "upper", 5))
3451                            namedclass =
3452                                complement ? ANYOF_NUPPER : ANYOF_UPPER;
3453                        break;
3454                    case 'w': /* this is not POSIX, this is the Perl \w */
3455                        if (strnEQ(posixcc, "word", 4)) {
3456                            namedclass =
3457                                complement ? ANYOF_NALNUM : ANYOF_ALNUM;
3458                            skip = 4;
3459                        }
3460                        break;
3461                    case 'x':
3462                        if (strnEQ(posixcc, "xdigit", 6)) {
3463                            namedclass =
3464                                complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
3465                            skip = 6;
3466                        }
3467                        break;
3468                    }
3469                    if (namedclass == OOB_NAMEDCLASS ||
3470                        posixcc[skip] != ':' ||
3471                        posixcc[skip+1] != ']')
3472                    {
3473                        Simple_vFAIL3("POSIX class [:%.*s:] unknown",
3474                                      t - s - 1, s + 1);
3475                    }
3476                } else if (!SIZE_ONLY) {
3477                    /* [[=foo=]] and [[.foo.]] are still future. */
3478
3479                    /* adjust RExC_parse so the warning shows after
3480                       the class closes */
3481                    while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
3482                        RExC_parse++;
3483                    Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
3484                }
3485            } else {
3486                /* Maternal grandfather:
3487                 * "[:" ending in ":" but not in ":]" */
3488                RExC_parse = s;
3489            }
3490        }
3491    }
3492
3493    return namedclass;
3494}
3495
3496STATIC void
3497S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
3498{
3499    if (!SIZE_ONLY && POSIXCC(UCHARAT(RExC_parse))) {
3500        char *s = RExC_parse;
3501        char  c = *s++;
3502
3503        while(*s && isALNUM(*s))
3504            s++;
3505        if (*s && c == *s && s[1] == ']') {
3506            if (ckWARN(WARN_REGEXP))
3507                vWARN3(s+2,
3508                        "POSIX syntax [%c %c] belongs inside character classes",
3509                        c, c);
3510
3511            /* [[=foo=]] and [[.foo.]] are still future. */
3512            if (POSIXCC_NOTYET(c)) {
3513                /* adjust RExC_parse so the error shows after
3514                   the class closes */
3515                while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
3516                    ;
3517                Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
3518            }
3519        }
3520    }
3521}
3522
3523STATIC regnode *
3524S_regclass(pTHX_ RExC_state_t *pRExC_state)
3525{
3526    register UV value;
3527    register UV nextvalue;
3528    register IV prevvalue = OOB_UNICODE;
3529    register IV range = 0;
3530    register regnode *ret;
3531    STRLEN numlen;
3532    IV namedclass;
3533    char *rangebegin = 0;
3534    bool need_class = 0;
3535    SV *listsv = Nullsv;
3536    register char *e;
3537    UV n;
3538    bool optimize_invert   = TRUE;
3539    AV* unicode_alternate  = 0;
3540#ifdef EBCDIC
3541    UV literal_endpoint = 0;
3542#endif
3543
3544    ret = reganode(pRExC_state, ANYOF, 0);
3545
3546    if (!SIZE_ONLY)
3547        ANYOF_FLAGS(ret) = 0;
3548
3549    if (UCHARAT(RExC_parse) == '^') {   /* Complement of range. */
3550        RExC_naughty++;
3551        RExC_parse++;
3552        if (!SIZE_ONLY)
3553            ANYOF_FLAGS(ret) |= ANYOF_INVERT;
3554    }
3555
3556    if (SIZE_ONLY)
3557        RExC_size += ANYOF_SKIP;
3558    else {
3559        RExC_emit += ANYOF_SKIP;
3560        if (FOLD)
3561            ANYOF_FLAGS(ret) |= ANYOF_FOLD;
3562        if (LOC)
3563            ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
3564        ANYOF_BITMAP_ZERO(ret);
3565        listsv = newSVpvn("# comment\n", 10);
3566    }
3567
3568    nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
3569
3570    if (!SIZE_ONLY && POSIXCC(nextvalue))
3571        checkposixcc(pRExC_state);
3572
3573    /* allow 1st char to be ] (allowing it to be - is dealt with later) */
3574    if (UCHARAT(RExC_parse) == ']')
3575        goto charclassloop;
3576
3577    while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
3578
3579    charclassloop:
3580
3581        namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
3582
3583        if (!range)
3584            rangebegin = RExC_parse;
3585        if (UTF) {
3586            value = utf8n_to_uvchr((U8*)RExC_parse,
3587                                   RExC_end - RExC_parse,
3588                                   &numlen, 0);
3589            RExC_parse += numlen;
3590        }
3591        else
3592            value = UCHARAT(RExC_parse++);
3593        nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
3594        if (value == '[' && POSIXCC(nextvalue))
3595            namedclass = regpposixcc(pRExC_state, value);
3596        else if (value == '\\') {
3597            if (UTF) {
3598                value = utf8n_to_uvchr((U8*)RExC_parse,
3599                                   RExC_end - RExC_parse,
3600                                   &numlen, 0);
3601                RExC_parse += numlen;
3602            }
3603            else
3604                value = UCHARAT(RExC_parse++);
3605            /* Some compilers cannot handle switching on 64-bit integer
3606             * values, therefore value cannot be an UV.  Yes, this will
3607             * be a problem later if we want switch on Unicode.
3608             * A similar issue a little bit later when switching on
3609             * namedclass. --jhi */
3610            switch ((I32)value) {
3611            case 'w':   namedclass = ANYOF_ALNUM;       break;
3612            case 'W':   namedclass = ANYOF_NALNUM;      break;
3613            case 's':   namedclass = ANYOF_SPACE;       break;
3614            case 'S':   namedclass = ANYOF_NSPACE;      break;
3615            case 'd':   namedclass = ANYOF_DIGIT;       break;
3616            case 'D':   namedclass = ANYOF_NDIGIT;      break;
3617            case 'p':
3618            case 'P':
3619                if (RExC_parse >= RExC_end)
3620                    vFAIL2("Empty \\%c{}", (U8)value);
3621                if (*RExC_parse == '{') {
3622                    U8 c = (U8)value;
3623                    e = strchr(RExC_parse++, '}');
3624                    if (!e)
3625                        vFAIL2("Missing right brace on \\%c{}", c);
3626                    while (isSPACE(UCHARAT(RExC_parse)))
3627                        RExC_parse++;
3628                    if (e == RExC_parse)
3629                        vFAIL2("Empty \\%c{}", c);
3630                    n = e - RExC_parse;
3631                    while (isSPACE(UCHARAT(RExC_parse + n - 1)))
3632                        n--;
3633                }
3634                else {
3635                    e = RExC_parse;
3636                    n = 1;
3637                }
3638                if (!SIZE_ONLY) {
3639                    if (UCHARAT(RExC_parse) == '^') {
3640                         RExC_parse++;
3641                         n--;
3642                         value = value == 'p' ? 'P' : 'p'; /* toggle */
3643                         while (isSPACE(UCHARAT(RExC_parse))) {
3644                              RExC_parse++;
3645                              n--;
3646                         }
3647                    }
3648                    if (value == 'p')
3649                         Perl_sv_catpvf(aTHX_ listsv,
3650                                        "+utf8::%.*s\n", (int)n, RExC_parse);
3651                    else
3652                         Perl_sv_catpvf(aTHX_ listsv,
3653                                        "!utf8::%.*s\n", (int)n, RExC_parse);
3654                }
3655                RExC_parse = e + 1;
3656                ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
3657                continue;
3658            case 'n':   value = '\n';                   break;
3659            case 'r':   value = '\r';                   break;
3660            case 't':   value = '\t';                   break;
3661            case 'f':   value = '\f';                   break;
3662            case 'b':   value = '\b';                   break;
3663            case 'e':   value = ASCII_TO_NATIVE('\033');break;
3664            case 'a':   value = ASCII_TO_NATIVE('\007');break;
3665            case 'x':
3666                if (*RExC_parse == '{') {
3667                    I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3668                        | PERL_SCAN_DISALLOW_PREFIX;
3669                    e = strchr(RExC_parse++, '}');
3670                    if (!e)
3671                        vFAIL("Missing right brace on \\x{}");
3672
3673                    numlen = e - RExC_parse;
3674                    value = grok_hex(RExC_parse, &numlen, &flags, NULL);
3675                    RExC_parse = e + 1;
3676                }
3677                else {
3678                    I32 flags = PERL_SCAN_DISALLOW_PREFIX;
3679                    numlen = 2;
3680                    value = grok_hex(RExC_parse, &numlen, &flags, NULL);
3681                    RExC_parse += numlen;
3682                }
3683                break;
3684            case 'c':
3685                value = UCHARAT(RExC_parse++);
3686                value = toCTRL(value);
3687                break;
3688            case '0': case '1': case '2': case '3': case '4':
3689            case '5': case '6': case '7': case '8': case '9':
3690            {
3691                I32 flags = 0;
3692                numlen = 3;
3693                value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
3694                RExC_parse += numlen;
3695                break;
3696            }
3697            default:
3698                if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && isALPHA(value))
3699                    vWARN2(RExC_parse,
3700                           "Unrecognized escape \\%c in character class passed through",
3701                           (int)value);
3702                break;
3703            }
3704        } /* end of \blah */
3705#ifdef EBCDIC
3706        else
3707            literal_endpoint++;
3708#endif
3709
3710        if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
3711
3712            if (!SIZE_ONLY && !need_class)
3713                ANYOF_CLASS_ZERO(ret);
3714
3715            need_class = 1;
3716
3717            /* a bad range like a-\d, a-[:digit:] ? */
3718            if (range) {
3719                if (!SIZE_ONLY) {
3720                    if (ckWARN(WARN_REGEXP))
3721                        vWARN4(RExC_parse,
3722                               "False [] range \"%*.*s\"",
3723                               RExC_parse - rangebegin,
3724                               RExC_parse - rangebegin,
3725                               rangebegin);
3726                    if (prevvalue < 256) {
3727                        ANYOF_BITMAP_SET(ret, prevvalue);
3728                        ANYOF_BITMAP_SET(ret, '-');
3729                    }
3730                    else {
3731                        ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
3732                        Perl_sv_catpvf(aTHX_ listsv,
3733                                       "%04"UVxf"\n%04"UVxf"\n", (UV)prevvalue, (UV) '-');
3734                    }
3735                }
3736
3737                range = 0; /* this was not a true range */
3738            }
3739
3740            if (!SIZE_ONLY) {
3741                if (namedclass > OOB_NAMEDCLASS)
3742                    optimize_invert = FALSE;
3743                /* Possible truncation here but in some 64-bit environments
3744                 * the compiler gets heartburn about switch on 64-bit values.
3745                 * A similar issue a little earlier when switching on value.
3746                 * --jhi */
3747                switch ((I32)namedclass) {
3748                case ANYOF_ALNUM:
3749                    if (LOC)
3750                        ANYOF_CLASS_SET(ret, ANYOF_ALNUM);
3751                    else {
3752                        for (value = 0; value < 256; value++)
3753                            if (isALNUM(value))
3754                                ANYOF_BITMAP_SET(ret, value);
3755                    }
3756                    Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsWord\n");   
3757                    break;
3758                case ANYOF_NALNUM:
3759                    if (LOC)
3760                        ANYOF_CLASS_SET(ret, ANYOF_NALNUM);
3761                    else {
3762                        for (value = 0; value < 256; value++)
3763                            if (!isALNUM(value))
3764                                ANYOF_BITMAP_SET(ret, value);
3765                    }
3766                    Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsWord\n");
3767                    break;
3768                case ANYOF_ALNUMC:
3769                    if (LOC)
3770                        ANYOF_CLASS_SET(ret, ANYOF_ALNUMC);
3771                    else {
3772                        for (value = 0; value < 256; value++)
3773                            if (isALNUMC(value))
3774                                ANYOF_BITMAP_SET(ret, value);
3775                    }
3776                    Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsAlnum\n");
3777                    break;
3778                case ANYOF_NALNUMC:
3779                    if (LOC)
3780                        ANYOF_CLASS_SET(ret, ANYOF_NALNUMC);
3781                    else {
3782                        for (value = 0; value < 256; value++)
3783                            if (!isALNUMC(value))
3784                                ANYOF_BITMAP_SET(ret, value);
3785                    }
3786                    Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsAlnum\n");
3787                    break;
3788                case ANYOF_ALPHA:
3789                    if (LOC)
3790                        ANYOF_CLASS_SET(ret, ANYOF_ALPHA);
3791                    else {
3792                        for (value = 0; value < 256; value++)
3793                            if (isALPHA(value))
3794                                ANYOF_BITMAP_SET(ret, value);
3795                    }
3796                    Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsAlpha\n");
3797                    break;
3798                case ANYOF_NALPHA:
3799                    if (LOC)
3800                        ANYOF_CLASS_SET(ret, ANYOF_NALPHA);
3801                    else {
3802                        for (value = 0; value < 256; value++)
3803                            if (!isALPHA(value))
3804                                ANYOF_BITMAP_SET(ret, value);
3805                    }
3806                    Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsAlpha\n");
3807                    break;
3808                case ANYOF_ASCII:
3809                    if (LOC)
3810                        ANYOF_CLASS_SET(ret, ANYOF_ASCII);
3811                    else {
3812#ifndef EBCDIC
3813                        for (value = 0; value < 128; value++)
3814                            ANYOF_BITMAP_SET(ret, value);
3815#else  /* EBCDIC */
3816                        for (value = 0; value < 256; value++) {
3817                            if (isASCII(value))
3818                                ANYOF_BITMAP_SET(ret, value);
3819                        }
3820#endif /* EBCDIC */
3821                    }
3822                    Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsASCII\n");
3823                    break;
3824                case ANYOF_NASCII:
3825                    if (LOC)
3826                        ANYOF_CLASS_SET(ret, ANYOF_NASCII);
3827                    else {
3828#ifndef EBCDIC
3829                        for (value = 128; value < 256; value++)
3830                            ANYOF_BITMAP_SET(ret, value);
3831#else  /* EBCDIC */
3832                        for (value = 0; value < 256; value++) {
3833                            if (!isASCII(value))
3834                                ANYOF_BITMAP_SET(ret, value);
3835                        }
3836#endif /* EBCDIC */
3837                    }
3838                    Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsASCII\n");
3839                    break;
3840                case ANYOF_BLANK:
3841                    if (LOC)
3842                        ANYOF_CLASS_SET(ret, ANYOF_BLANK);
3843                    else {
3844                        for (value = 0; value < 256; value++)
3845                            if (isBLANK(value))
3846                                ANYOF_BITMAP_SET(ret, value);
3847                    }
3848                    Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsBlank\n");
3849                    break;
3850                case ANYOF_NBLANK:
3851                    if (LOC)
3852                        ANYOF_CLASS_SET(ret, ANYOF_NBLANK);
3853                    else {
3854                        for (value = 0; value < 256; value++)
3855                            if (!isBLANK(value))
3856                                ANYOF_BITMAP_SET(ret, value);
3857                    }
3858                    Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsBlank\n");
3859                    break;
3860                case ANYOF_CNTRL:
3861                    if (LOC)
3862                        ANYOF_CLASS_SET(ret, ANYOF_CNTRL);
3863                    else {
3864                        for (value = 0; value < 256; value++)
3865                            if (isCNTRL(value))
3866                                ANYOF_BITMAP_SET(ret, value);
3867                    }
3868                    Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsCntrl\n");
3869                    break;
3870                case ANYOF_NCNTRL:
3871                    if (LOC)
3872                        ANYOF_CLASS_SET(ret, ANYOF_NCNTRL);
3873                    else {
3874                        for (value = 0; value < 256; value++)
3875                            if (!isCNTRL(value))
3876                                ANYOF_BITMAP_SET(ret, value);
3877                    }
3878                    Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsCntrl\n");
3879                    break;
3880                case ANYOF_DIGIT:
3881                    if (LOC)
3882                        ANYOF_CLASS_SET(ret, ANYOF_DIGIT);
3883                    else {
3884                        /* consecutive digits assumed */
3885                        for (value = '0'; value <= '9'; value++)
3886                            ANYOF_BITMAP_SET(ret, value);
3887                    }
3888                    Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsDigit\n");
3889                    break;
3890                case ANYOF_NDIGIT:
3891                    if (LOC)
3892                        ANYOF_CLASS_SET(ret, ANYOF_NDIGIT);
3893                    else {
3894                        /* consecutive digits assumed */
3895                        for (value = 0; value < '0'; value++)
3896                            ANYOF_BITMAP_SET(ret, value);
3897                        for (value = '9' + 1; value < 256; value++)
3898                            ANYOF_BITMAP_SET(ret, value);
3899                    }
3900                    Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsDigit\n");
3901                    break;
3902                case ANYOF_GRAPH:
3903                    if (LOC)
3904                        ANYOF_CLASS_SET(ret, ANYOF_GRAPH);
3905                    else {
3906                        for (value = 0; value < 256; value++)
3907                            if (isGRAPH(value))
3908                                ANYOF_BITMAP_SET(ret, value);
3909                    }
3910                    Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsGraph\n");
3911                    break;
3912                case ANYOF_NGRAPH:
3913                    if (LOC)
3914                        ANYOF_CLASS_SET(ret, ANYOF_NGRAPH);
3915                    else {
3916                        for (value = 0; value < 256; value++)
3917                            if (!isGRAPH(value))
3918                                ANYOF_BITMAP_SET(ret, value);
3919                    }
3920                    Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsGraph\n");
3921                    break;
3922                case ANYOF_LOWER:
3923                    if (LOC)
3924                        ANYOF_CLASS_SET(ret, ANYOF_LOWER);
3925                    else {
3926                        for (value = 0; value < 256; value++)
3927                            if (isLOWER(value))
3928                                ANYOF_BITMAP_SET(ret, value);
3929                    }
3930                    Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsLower\n");
3931                    break;
3932                case ANYOF_NLOWER:
3933                    if (LOC)
3934                        ANYOF_CLASS_SET(ret, ANYOF_NLOWER);
3935                    else {
3936                        for (value = 0; value < 256; value++)
3937                            if (!isLOWER(value))
3938                                ANYOF_BITMAP_SET(ret, value);
3939                    }
3940                    Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsLower\n");
3941                    break;
3942                case ANYOF_PRINT:
3943                    if (LOC)
3944                        ANYOF_CLASS_SET(ret, ANYOF_PRINT);
3945                    else {
3946                        for (value = 0; value < 256; value++)
3947                            if (isPRINT(value))
3948                                ANYOF_BITMAP_SET(ret, value);
3949                    }
3950                    Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsPrint\n");
3951                    break;
3952                case ANYOF_NPRINT:
3953                    if (LOC)
3954                        ANYOF_CLASS_SET(ret, ANYOF_NPRINT);
3955                    else {
3956                        for (value = 0; value < 256; value++)
3957                            if (!isPRINT(value))
3958                                ANYOF_BITMAP_SET(ret, value);
3959                    }
3960                    Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsPrint\n");
3961                    break;
3962                case ANYOF_PSXSPC:
3963                    if (LOC)
3964                        ANYOF_CLASS_SET(ret, ANYOF_PSXSPC);
3965                    else {
3966                        for (value = 0; value < 256; value++)
3967                            if (isPSXSPC(value))
3968                                ANYOF_BITMAP_SET(ret, value);
3969                    }
3970                    Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsSpace\n");
3971                    break;
3972                case ANYOF_NPSXSPC:
3973                    if (LOC)
3974                        ANYOF_CLASS_SET(ret, ANYOF_NPSXSPC);
3975                    else {
3976                        for (value = 0; value < 256; value++)
3977                            if (!isPSXSPC(value))
3978                                ANYOF_BITMAP_SET(ret, value);
3979                    }
3980                    Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsSpace\n");
3981                    break;
3982                case ANYOF_PUNCT:
3983                    if (LOC)
3984                        ANYOF_CLASS_SET(ret, ANYOF_PUNCT);
3985                    else {
3986                        for (value = 0; value < 256; value++)
3987                            if (isPUNCT(value))
3988                                ANYOF_BITMAP_SET(ret, value);
3989                    }
3990                    Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsPunct\n");
3991                    break;
3992                case ANYOF_NPUNCT:
3993                    if (LOC)
3994                        ANYOF_CLASS_SET(ret, ANYOF_NPUNCT);
3995                    else {
3996                        for (value = 0; value < 256; value++)
3997                            if (!isPUNCT(value))
3998                                ANYOF_BITMAP_SET(ret, value);
3999                    }
4000                    Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsPunct\n");
4001                    break;
4002                case ANYOF_SPACE:
4003                    if (LOC)
4004                        ANYOF_CLASS_SET(ret, ANYOF_SPACE);
4005                    else {
4006                        for (value = 0; value < 256; value++)
4007                            if (isSPACE(value))
4008                                ANYOF_BITMAP_SET(ret, value);
4009                    }
4010                    Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsSpacePerl\n");
4011                    break;
4012                case ANYOF_NSPACE:
4013                    if (LOC)
4014                        ANYOF_CLASS_SET(ret, ANYOF_NSPACE);
4015                    else {
4016                        for (value = 0; value < 256; value++)
4017                            if (!isSPACE(value))
4018                                ANYOF_BITMAP_SET(ret, value);
4019                    }
4020                    Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsSpacePerl\n");
4021                    break;
4022                case ANYOF_UPPER:
4023                    if (LOC)
4024                        ANYOF_CLASS_SET(ret, ANYOF_UPPER);
4025                    else {
4026                        for (value = 0; value < 256; value++)
4027                            if (isUPPER(value))
4028                                ANYOF_BITMAP_SET(ret, value);
4029                    }
4030                    Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsUpper\n");
4031                    break;
4032                case ANYOF_NUPPER:
4033                    if (LOC)
4034                        ANYOF_CLASS_SET(ret, ANYOF_NUPPER);
4035                    else {
4036                        for (value = 0; value < 256; value++)
4037                            if (!isUPPER(value))
4038                                ANYOF_BITMAP_SET(ret, value);
4039                    }
4040                    Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsUpper\n");
4041                    break;
4042                case ANYOF_XDIGIT:
4043                    if (LOC)
4044                        ANYOF_CLASS_SET(ret, ANYOF_XDIGIT);
4045                    else {
4046                        for (value = 0; value < 256; value++)
4047                            if (isXDIGIT(value))
4048                                ANYOF_BITMAP_SET(ret, value);
4049                    }
4050                    Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsXDigit\n");
4051                    break;
4052                case ANYOF_NXDIGIT:
4053                    if (LOC)
4054                        ANYOF_CLASS_SET(ret, ANYOF_NXDIGIT);
4055                    else {
4056                        for (value = 0; value < 256; value++)
4057                            if (!isXDIGIT(value))
4058                                ANYOF_BITMAP_SET(ret, value);
4059                    }
4060                    Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsXDigit\n");
4061                    break;
4062                default:
4063                    vFAIL("Invalid [::] class");
4064                    break;
4065                }
4066                if (LOC)
4067                    ANYOF_FLAGS(ret) |= ANYOF_CLASS;
4068                continue;
4069            }
4070        } /* end of namedclass \blah */
4071
4072        if (range) {
4073            if (prevvalue > (IV)value) /* b-a */ {
4074                Simple_vFAIL4("Invalid [] range \"%*.*s\"",
4075                              RExC_parse - rangebegin,
4076                              RExC_parse - rangebegin,
4077                              rangebegin);
4078                range = 0; /* not a valid range */
4079            }
4080        }
4081        else {
4082            prevvalue = value; /* save the beginning of the range */
4083            if (*RExC_parse == '-' && RExC_parse+1 < RExC_end &&
4084                RExC_parse[1] != ']') {
4085                RExC_parse++;
4086
4087                /* a bad range like \w-, [:word:]- ? */
4088                if (namedclass > OOB_NAMEDCLASS) {
4089                    if (ckWARN(WARN_REGEXP))
4090                        vWARN4(RExC_parse,
4091                               "False [] range \"%*.*s\"",
4092                               RExC_parse - rangebegin,
4093                               RExC_parse - rangebegin,
4094                               rangebegin);
4095                    if (!SIZE_ONLY)
4096                        ANYOF_BITMAP_SET(ret, '-');
4097                } else
4098                    range = 1;  /* yeah, it's a range! */
4099                continue;       /* but do it the next time */
4100            }
4101        }
4102
4103        /* now is the next time */
4104        if (!SIZE_ONLY) {
4105            IV i;
4106
4107            if (prevvalue < 256) {
4108                IV ceilvalue = value < 256 ? value : 255;
4109
4110#ifdef EBCDIC
4111                /* In EBCDIC [\x89-\x91] should include
4112                 * the \x8e but [i-j] should not. */
4113                if (literal_endpoint == 2 &&
4114                    ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
4115                     (isUPPER(prevvalue) && isUPPER(ceilvalue))))
4116                {
4117                    if (isLOWER(prevvalue)) {
4118                        for (i = prevvalue; i <= ceilvalue; i++)
4119                            if (isLOWER(i))
4120                                ANYOF_BITMAP_SET(ret, i);
4121                    } else {
4122                        for (i = prevvalue; i <= ceilvalue; i++)
4123                            if (isUPPER(i))
4124                                ANYOF_BITMAP_SET(ret, i);
4125                    }
4126                }
4127                else
4128#endif
4129                      for (i = prevvalue; i <= ceilvalue; i++)
4130                          ANYOF_BITMAP_SET(ret, i);
4131          }
4132          if (value > 255 || UTF) {
4133                UV prevnatvalue  = NATIVE_TO_UNI(prevvalue);
4134                UV natvalue      = NATIVE_TO_UNI(value);
4135
4136                ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
4137                if (prevnatvalue < natvalue) { /* what about > ? */
4138                    Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
4139                                   prevnatvalue, natvalue);
4140                }
4141                else if (prevnatvalue == natvalue) {
4142                    Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", natvalue);
4143                    if (FOLD) {
4144                         U8 foldbuf[UTF8_MAXLEN_FOLD+1];
4145                         STRLEN foldlen;
4146                         UV f = to_uni_fold(natvalue, foldbuf, &foldlen);
4147
4148                         /* If folding and foldable and a single
4149                          * character, insert also the folded version
4150                          * to the charclass. */
4151                         if (f != value) {
4152                              if (foldlen == (STRLEN)UNISKIP(f))
4153                                  Perl_sv_catpvf(aTHX_ listsv,
4154                                                 "%04"UVxf"\n", f);
4155                              else {
4156                                  /* Any multicharacter foldings
4157                                   * require the following transform:
4158                                   * [ABCDEF] -> (?:[ABCabcDEFd]|pq|rst)
4159                                   * where E folds into "pq" and F folds
4160                                   * into "rst", all other characters
4161                                   * fold to single characters.  We save
4162                                   * away these multicharacter foldings,
4163                                   * to be later saved as part of the
4164                                   * additional "s" data. */
4165                                  SV *sv;
4166
4167                                  if (!unicode_alternate)
4168                                      unicode_alternate = newAV();
4169                                  sv = newSVpvn((char*)foldbuf, foldlen);
4170                                  SvUTF8_on(sv);
4171                                  av_push(unicode_alternate, sv);
4172                              }
4173                         }
4174
4175                         /* If folding and the value is one of the Greek
4176                          * sigmas insert a few more sigmas to make the
4177                          * folding rules of the sigmas to work right.
4178                          * Note that not all the possible combinations
4179                          * are handled here: some of them are handled
4180                          * by the standard folding rules, and some of
4181                          * them (literal or EXACTF cases) are handled
4182                          * during runtime in regexec.c:S_find_byclass(). */
4183                         if (value == UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA) {
4184                              Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
4185                                             (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA);
4186                              Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
4187                                             (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
4188                         }
4189                         else if (value == UNICODE_GREEK_CAPITAL_LETTER_SIGMA)
4190                              Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
4191                                             (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
4192                    }
4193                }
4194            }
4195#ifdef EBCDIC
4196            literal_endpoint = 0;
4197#endif
4198        }
4199
4200        range = 0; /* this range (if it was one) is done now */
4201    }
4202
4203    if (need_class) {
4204        ANYOF_FLAGS(ret) |= ANYOF_LARGE;
4205        if (SIZE_ONLY)
4206            RExC_size += ANYOF_CLASS_ADD_SKIP;
4207        else
4208            RExC_emit += ANYOF_CLASS_ADD_SKIP;
4209    }
4210
4211    /* optimize case-insensitive simple patterns (e.g. /[a-z]/i) */
4212    if (!SIZE_ONLY &&
4213         /* If the only flag is folding (plus possibly inversion). */
4214        ((ANYOF_FLAGS(ret) & (ANYOF_FLAGS_ALL ^ ANYOF_INVERT)) == ANYOF_FOLD)
4215       ) {
4216        for (value = 0; value < 256; ++value) {
4217            if (ANYOF_BITMAP_TEST(ret, value)) {
4218                UV fold = PL_fold[value];
4219
4220                if (fold != value)
4221                    ANYOF_BITMAP_SET(ret, fold);
4222            }
4223        }
4224        ANYOF_FLAGS(ret) &= ~ANYOF_FOLD;
4225    }
4226
4227    /* optimize inverted simple patterns (e.g. [^a-z]) */
4228    if (!SIZE_ONLY && optimize_invert &&
4229        /* If the only flag is inversion. */
4230        (ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT) {
4231        for (value = 0; value < ANYOF_BITMAP_SIZE; ++value)
4232            ANYOF_BITMAP(ret)[value] ^= ANYOF_FLAGS_ALL;
4233        ANYOF_FLAGS(ret) = ANYOF_UNICODE_ALL;
4234    }
4235
4236    if (!SIZE_ONLY) {
4237        AV *av = newAV();
4238        SV *rv;
4239
4240        /* The 0th element stores the character class description
4241         * in its textual form: used later (regexec.c:Perl_regclass_swash())
4242         * to initialize the appropriate swash (which gets stored in
4243         * the 1st element), and also useful for dumping the regnode.
4244         * The 2nd element stores the multicharacter foldings,
4245         * used later (regexec.c:S_reginclass()). */
4246        av_store(av, 0, listsv);
4247        av_store(av, 1, NULL);
4248        av_store(av, 2, (SV*)unicode_alternate);
4249        rv = newRV_noinc((SV*)av);
4250        n = add_data(pRExC_state, 1, "s");
4251        RExC_rx->data->data[n] = (void*)rv;
4252        ARG_SET(ret, n);
4253    }
4254
4255    return ret;
4256}
4257
4258STATIC char*
4259S_nextchar(pTHX_ RExC_state_t *pRExC_state)
4260{
4261    char* retval = RExC_parse++;
4262
4263    for (;;) {
4264        if (*RExC_parse == '(' && RExC_parse[1] == '?' &&
4265                RExC_parse[2] == '#') {
4266            while (*RExC_parse != ')') {
4267                if (RExC_parse == RExC_end)
4268                    FAIL("Sequence (?#... not terminated");
4269                RExC_parse++;
4270            }
4271            RExC_parse++;
4272            continue;
4273        }
4274        if (RExC_flags & PMf_EXTENDED) {
4275            if (isSPACE(*RExC_parse)) {
4276                RExC_parse++;
4277                continue;
4278            }
4279            else if (*RExC_parse == '#') {
4280                while (RExC_parse < RExC_end)
4281                    if (*RExC_parse++ == '\n') break;
4282                continue;
4283            }
4284        }
4285        return retval;
4286    }
4287}
4288
4289/*
4290- reg_node - emit a node
4291*/
4292STATIC regnode *                        /* Location. */
4293S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
4294{
4295    register regnode *ret;
4296    register regnode *ptr;
4297
4298    ret = RExC_emit;
4299    if (SIZE_ONLY) {
4300        SIZE_ALIGN(RExC_size);
4301        RExC_size += 1;
4302        return(ret);
4303    }
4304
4305    NODE_ALIGN_FILL(ret);
4306    ptr = ret;
4307    FILL_ADVANCE_NODE(ptr, op);
4308    if (RExC_offsets) {         /* MJD */
4309        MJD_OFFSET_DEBUG(("%s:%u: (op %s) %s %u <- %u (len %u) (max %u).\n",
4310              "reg_node", __LINE__,
4311              reg_name[op],
4312              RExC_emit - RExC_emit_start > RExC_offsets[0]
4313              ? "Overwriting end of array!\n" : "OK",
4314              RExC_emit - RExC_emit_start,
4315              RExC_parse - RExC_start,
4316              RExC_offsets[0]));
4317        Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
4318    }
4319           
4320    RExC_emit = ptr;
4321
4322    return(ret);
4323}
4324
4325/*
4326- reganode - emit a node with an argument
4327*/
4328STATIC regnode *                        /* Location. */
4329S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
4330{
4331    register regnode *ret;
4332    register regnode *ptr;
4333
4334    ret = RExC_emit;
4335    if (SIZE_ONLY) {
4336        SIZE_ALIGN(RExC_size);
4337        RExC_size += 2;
4338        return(ret);
4339    }
4340
4341    NODE_ALIGN_FILL(ret);
4342    ptr = ret;
4343    FILL_ADVANCE_NODE_ARG(ptr, op, arg);
4344    if (RExC_offsets) {         /* MJD */
4345        MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %u <- %u (max %u).\n",
4346              "reganode",
4347              __LINE__,
4348              reg_name[op],
4349              RExC_emit - RExC_emit_start > RExC_offsets[0] ?
4350              "Overwriting end of array!\n" : "OK",
4351              RExC_emit - RExC_emit_start,
4352              RExC_parse - RExC_start,
4353              RExC_offsets[0]));
4354        Set_Cur_Node_Offset;
4355    }
4356           
4357    RExC_emit = ptr;
4358
4359    return(ret);
4360}
4361
4362/*
4363- reguni - emit (if appropriate) a Unicode character
4364*/
4365STATIC void
4366S_reguni(pTHX_ RExC_state_t *pRExC_state, UV uv, char* s, STRLEN* lenp)
4367{
4368    *lenp = SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
4369}
4370
4371/*
4372- reginsert - insert an operator in front of already-emitted operand
4373*
4374* Means relocating the operand.
4375*/
4376STATIC void
4377S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd)
4378{
4379    register regnode *src;
4380    register regnode *dst;
4381    register regnode *place;
4382    register int offset = regarglen[(U8)op];
4383
4384/* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
4385
4386    if (SIZE_ONLY) {
4387        RExC_size += NODE_STEP_REGNODE + offset;
4388        return;
4389    }
4390
4391    src = RExC_emit;
4392    RExC_emit += NODE_STEP_REGNODE + offset;
4393    dst = RExC_emit;
4394    while (src > opnd) {
4395        StructCopy(--src, --dst, regnode);
4396        if (RExC_offsets) {     /* MJD 20010112 */
4397            MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %u -> %u (max %u).\n",
4398                  "reg_insert",
4399                  __LINE__,
4400                  reg_name[op],
4401                  dst - RExC_emit_start > RExC_offsets[0]
4402                  ? "Overwriting end of array!\n" : "OK",
4403                  src - RExC_emit_start,
4404                  dst - RExC_emit_start,
4405                  RExC_offsets[0]));
4406            Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
4407            Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
4408        }
4409    }
4410   
4411
4412    place = opnd;               /* Op node, where operand used to be. */
4413    if (RExC_offsets) {         /* MJD */
4414        MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %u <- %u (max %u).\n",
4415              "reginsert",
4416              __LINE__,
4417              reg_name[op],
4418              place - RExC_emit_start > RExC_offsets[0]
4419              ? "Overwriting end of array!\n" : "OK",
4420              place - RExC_emit_start,
4421              RExC_parse - RExC_start,
4422              RExC_offsets[0]));
4423        Set_Node_Offset(place, RExC_parse);
4424        Set_Node_Length(place, 1);
4425    }
4426    src = NEXTOPER(place);
4427    FILL_ADVANCE_NODE(place, op);
4428    Zero(src, offset, regnode);
4429}
4430
4431/*
4432- regtail - set the next-pointer at the end of a node chain of p to val.
4433*/
4434STATIC void
4435S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, regnode *val)
4436{
4437    register regnode *scan;
4438    register regnode *temp;
4439
4440    if (SIZE_ONLY)
4441        return;
4442
4443    /* Find last node. */
4444    scan = p;
4445    for (;;) {
4446        temp = regnext(scan);
4447        if (temp == NULL)
4448            break;
4449        scan = temp;
4450    }
4451
4452    if (reg_off_by_arg[OP(scan)]) {
4453        ARG_SET(scan, val - scan);
4454    }
4455    else {
4456        NEXT_OFF(scan) = val - scan;
4457    }
4458}
4459
4460/*
4461- regoptail - regtail on operand of first argument; nop if operandless
4462*/
4463STATIC void
4464S_regoptail(pTHX_ RExC_state_t *pRExC_state, regnode *p, regnode *val)
4465{
4466    /* "Operandless" and "op != BRANCH" are synonymous in practice. */
4467    if (p == NULL || SIZE_ONLY)
4468        return;
4469    if (PL_regkind[(U8)OP(p)] == BRANCH) {
4470        regtail(pRExC_state, NEXTOPER(p), val);
4471    }
4472    else if ( PL_regkind[(U8)OP(p)] == BRANCHJ) {
4473        regtail(pRExC_state, NEXTOPER(NEXTOPER(p)), val);
4474    }
4475    else
4476        return;
4477}
4478
4479/*
4480 - regcurly - a little FSA that accepts {\d+,?\d*}
4481 */
4482STATIC I32
4483S_regcurly(pTHX_ register char *s)
4484{
4485    if (*s++ != '{')
4486        return FALSE;
4487    if (!isDIGIT(*s))
4488        return FALSE;
4489    while (isDIGIT(*s))
4490        s++;
4491    if (*s == ',')
4492        s++;
4493    while (isDIGIT(*s))
4494        s++;
4495    if (*s != '}')
4496        return FALSE;
4497    return TRUE;
4498}
4499
4500
4501#ifdef DEBUGGING
4502
4503STATIC regnode *
4504S_dumpuntil(pTHX_ regnode *start, regnode *node, regnode *last, SV* sv, I32 l)
4505{
4506    register U8 op = EXACT;     /* Arbitrary non-END op. */
4507    register regnode *next;
4508
4509    while (op != END && (!last || node < last)) {
4510        /* While that wasn't END last time... */
4511
4512        NODE_ALIGN(node);
4513        op = OP(node);
4514        if (op == CLOSE)
4515            l--;       
4516        next = regnext(node);
4517        /* Where, what. */
4518        if (OP(node) == OPTIMIZED)
4519            goto after_print;
4520        regprop(sv, node);
4521        PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
4522                      (int)(2*l + 1), "", SvPVX(sv));
4523        if (next == NULL)               /* Next ptr. */
4524            PerlIO_printf(Perl_debug_log, "(0)");
4525        else
4526            PerlIO_printf(Perl_debug_log, "(%"IVdf")", (IV)(next - start));
4527        (void)PerlIO_putc(Perl_debug_log, '\n');
4528      after_print:
4529        if (PL_regkind[(U8)op] == BRANCHJ) {
4530            register regnode *nnode = (OP(next) == LONGJMP
4531                                       ? regnext(next)
4532                                       : next);
4533            if (last && nnode > last)
4534                nnode = last;
4535            node = dumpuntil(start, NEXTOPER(NEXTOPER(node)), nnode, sv, l + 1);
4536        }
4537        else if (PL_regkind[(U8)op] == BRANCH) {
4538            node = dumpuntil(start, NEXTOPER(node), next, sv, l + 1);
4539        }
4540        else if ( op == CURLY) {   /* `next' might be very big: optimizer */
4541            node = dumpuntil(start, NEXTOPER(node) + EXTRA_STEP_2ARGS,
4542                             NEXTOPER(node) + EXTRA_STEP_2ARGS + 1, sv, l + 1);
4543        }
4544        else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
4545            node = dumpuntil(start, NEXTOPER(node) + EXTRA_STEP_2ARGS,
4546                             next, sv, l + 1);
4547        }
4548        else if ( op == PLUS || op == STAR) {
4549            node = dumpuntil(start, NEXTOPER(node), NEXTOPER(node) + 1, sv, l + 1);
4550        }
4551        else if (op == ANYOF) {
4552            /* arglen 1 + class block */
4553            node += 1 + ((ANYOF_FLAGS(node) & ANYOF_LARGE)
4554                    ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
4555            node = NEXTOPER(node);
4556        }
4557        else if (PL_regkind[(U8)op] == EXACT) {
4558            /* Literal string, where present. */
4559            node += NODE_SZ_STR(node) - 1;
4560            node = NEXTOPER(node);
4561        }
4562        else {
4563            node = NEXTOPER(node);
4564            node += regarglen[(U8)op];
4565        }
4566        if (op == CURLYX || op == OPEN)
4567            l++;
4568        else if (op == WHILEM)
4569            l--;
4570    }
4571    return node;
4572}
4573
4574#endif  /* DEBUGGING */
4575
4576/*
4577 - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
4578 */
4579void
4580Perl_regdump(pTHX_ regexp *r)
4581{
4582#ifdef DEBUGGING
4583    SV *sv = sv_newmortal();
4584
4585    (void)dumpuntil(r->program, r->program + 1, NULL, sv, 0);
4586
4587    /* Header fields of interest. */
4588    if (r->anchored_substr)
4589        PerlIO_printf(Perl_debug_log,
4590                      "anchored `%s%.*s%s'%s at %"IVdf" ",
4591                      PL_colors[0],
4592                      (int)(SvCUR(r->anchored_substr) - (SvTAIL(r->anchored_substr)!=0)),
4593                      SvPVX(r->anchored_substr),
4594                      PL_colors[1],
4595                      SvTAIL(r->anchored_substr) ? "$" : "",
4596                      (IV)r->anchored_offset);
4597    else if (r->anchored_utf8)
4598        PerlIO_printf(Perl_debug_log,
4599                      "anchored utf8 `%s%.*s%s'%s at %"IVdf" ",
4600                      PL_colors[0],
4601                      (int)(SvCUR(r->anchored_utf8) - (SvTAIL(r->anchored_utf8)!=0)),
4602                      SvPVX(r->anchored_utf8),
4603                      PL_colors[1],
4604                      SvTAIL(r->anchored_utf8) ? "$" : "",
4605                      (IV)r->anchored_offset);
4606    if (r->float_substr)
4607        PerlIO_printf(Perl_debug_log,
4608                      "floating `%s%.*s%s'%s at %"IVdf"..%"UVuf" ",
4609                      PL_colors[0],
4610                      (int)(SvCUR(r->float_substr) - (SvTAIL(r->float_substr)!=0)),
4611                      SvPVX(r->float_substr),
4612                      PL_colors[1],
4613                      SvTAIL(r->float_substr) ? "$" : "",
4614                      (IV)r->float_min_offset, (UV)r->float_max_offset);
4615    else if (r->float_utf8)
4616        PerlIO_printf(Perl_debug_log,
4617                      "floating utf8 `%s%.*s%s'%s at %"IVdf"..%"UVuf" ",
4618                      PL_colors[0],
4619                      (int)(SvCUR(r->float_utf8) - (SvTAIL(r->float_utf8)!=0)),
4620                      SvPVX(r->float_utf8),
4621                      PL_colors[1],
4622                      SvTAIL(r->float_utf8) ? "$" : "",
4623                      (IV)r->float_min_offset, (UV)r->float_max_offset);
4624    if (r->check_substr || r->check_utf8)
4625        PerlIO_printf(Perl_debug_log,
4626                      r->check_substr == r->float_substr
4627                      && r->check_utf8 == r->float_utf8
4628                      ? "(checking floating" : "(checking anchored");
4629    if (r->reganch & ROPT_NOSCAN)
4630        PerlIO_printf(Perl_debug_log, " noscan");
4631    if (r->reganch & ROPT_CHECK_ALL)
4632        PerlIO_printf(Perl_debug_log, " isall");
4633    if (r->check_substr || r->check_utf8)
4634        PerlIO_printf(Perl_debug_log, ") ");
4635
4636    if (r->regstclass) {
4637        regprop(sv, r->regstclass);
4638        PerlIO_printf(Perl_debug_log, "stclass `%s' ", SvPVX(sv));
4639    }
4640    if (r->reganch & ROPT_ANCH) {
4641        PerlIO_printf(Perl_debug_log, "anchored");
4642        if (r->reganch & ROPT_ANCH_BOL)
4643            PerlIO_printf(Perl_debug_log, "(BOL)");
4644        if (r->reganch & ROPT_ANCH_MBOL)
4645            PerlIO_printf(Perl_debug_log, "(MBOL)");
4646        if (r->reganch & ROPT_ANCH_SBOL)
4647            PerlIO_printf(Perl_debug_log, "(SBOL)");
4648        if (r->reganch & ROPT_ANCH_GPOS)
4649            PerlIO_printf(Perl_debug_log, "(GPOS)");
4650        PerlIO_putc(Perl_debug_log, ' ');
4651    }
4652    if (r->reganch & ROPT_GPOS_SEEN)
4653        PerlIO_printf(Perl_debug_log, "GPOS ");
4654    if (r->reganch & ROPT_SKIP)
4655        PerlIO_printf(Perl_debug_log, "plus ");
4656    if (r->reganch & ROPT_IMPLICIT)
4657        PerlIO_printf(Perl_debug_log, "implicit ");
4658    PerlIO_printf(Perl_debug_log, "minlen %ld ", (long) r->minlen);
4659    if (r->reganch & ROPT_EVAL_SEEN)
4660        PerlIO_printf(Perl_debug_log, "with eval ");
4661    PerlIO_printf(Perl_debug_log, "\n");
4662    if (r->offsets) {
4663      U32 i;
4664      U32 len = r->offsets[0];
4665      PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)r->offsets[0]);
4666      for (i = 1; i <= len; i++)
4667        PerlIO_printf(Perl_debug_log, "%"UVuf"[%"UVuf"] ",
4668                      (UV)r->offsets[i*2-1],
4669                      (UV)r->offsets[i*2]);
4670      PerlIO_printf(Perl_debug_log, "\n");
4671    }
4672#endif  /* DEBUGGING */
4673}
4674
4675#ifdef DEBUGGING
4676
4677STATIC void
4678S_put_byte(pTHX_ SV *sv, int c)
4679{
4680    if (isCNTRL(c) || c == 255 || !isPRINT(c))
4681        Perl_sv_catpvf(aTHX_ sv, "\\%o", c);
4682    else if (c == '-' || c == ']' || c == '\\' || c == '^')
4683        Perl_sv_catpvf(aTHX_ sv, "\\%c", c);
4684    else
4685        Perl_sv_catpvf(aTHX_ sv, "%c", c);
4686}
4687
4688#endif  /* DEBUGGING */
4689
4690/*
4691- regprop - printable representation of opcode
4692*/
4693void
4694Perl_regprop(pTHX_ SV *sv, regnode *o)
4695{
4696#ifdef DEBUGGING
4697    register int k;
4698
4699    sv_setpvn(sv, "", 0);
4700    if (OP(o) >= reg_num)               /* regnode.type is unsigned */
4701        /* It would be nice to FAIL() here, but this may be called from
4702           regexec.c, and it would be hard to supply pRExC_state. */
4703        Perl_croak(aTHX_ "Corrupted regexp opcode");
4704    sv_catpv(sv, (char*)reg_name[OP(o)]); /* Take off const! */
4705
4706    k = PL_regkind[(U8)OP(o)];
4707
4708    if (k == EXACT) {
4709        SV *dsv = sv_2mortal(newSVpvn("", 0));
4710        /* Using is_utf8_string() is a crude hack but it may
4711         * be the best for now since we have no flag "this EXACTish
4712         * node was UTF-8" --jhi */
4713        bool do_utf8 = is_utf8_string((U8*)STRING(o), STR_LEN(o));
4714        char *s    = do_utf8 ?
4715          pv_uni_display(dsv, (U8*)STRING(o), STR_LEN(o), 60,
4716                         UNI_DISPLAY_REGEX) :
4717          STRING(o);
4718        int len = do_utf8 ?
4719          strlen(s) :
4720          STR_LEN(o);
4721        Perl_sv_catpvf(aTHX_ sv, " <%s%.*s%s>",
4722                       PL_colors[0],
4723                       len, s,
4724                       PL_colors[1]);
4725    }
4726    else if (k == CURLY) {
4727        if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
4728            Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
4729        Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
4730    }
4731    else if (k == WHILEM && o->flags)                   /* Ordinal/of */
4732        Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
4733    else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP )
4734        Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o));    /* Parenth number */
4735    else if (k == LOGICAL)
4736        Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);     /* 2: embedded, otherwise 1 */
4737    else if (k == ANYOF) {
4738        int i, rangestart = -1;
4739        U8 flags = ANYOF_FLAGS(o);
4740        const char * const anyofs[] = { /* Should be synchronized with
4741                                         * ANYOF_ #xdefines in regcomp.h */
4742            "\\w",
4743            "\\W",
4744            "\\s",
4745            "\\S",
4746            "\\d",
4747            "\\D",
4748            "[:alnum:]",
4749            "[:^alnum:]",
4750            "[:alpha:]",
4751            "[:^alpha:]",
4752            "[:ascii:]",
4753            "[:^ascii:]",
4754            "[:ctrl:]",
4755            "[:^ctrl:]",
4756            "[:graph:]",
4757            "[:^graph:]",
4758            "[:lower:]",
4759            "[:^lower:]",
4760            "[:print:]",
4761            "[:^print:]",
4762            "[:punct:]",
4763            "[:^punct:]",
4764            "[:upper:]",
4765            "[:^upper:]",
4766            "[:xdigit:]",
4767            "[:^xdigit:]",
4768            "[:space:]",
4769            "[:^space:]",
4770            "[:blank:]",
4771            "[:^blank:]"
4772        };
4773
4774        if (flags & ANYOF_LOCALE)
4775            sv_catpv(sv, "{loc}");
4776        if (flags & ANYOF_FOLD)
4777            sv_catpv(sv, "{i}");
4778        Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
4779        if (flags & ANYOF_INVERT)
4780            sv_catpv(sv, "^");
4781        for (i = 0; i <= 256; i++) {
4782            if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
4783                if (rangestart == -1)
4784                    rangestart = i;
4785            } else if (rangestart != -1) {
4786                if (i <= rangestart + 3)
4787                    for (; rangestart < i; rangestart++)
4788                        put_byte(sv, rangestart);
4789                else {
4790                    put_byte(sv, rangestart);
4791                    sv_catpv(sv, "-");
4792                    put_byte(sv, i - 1);
4793                }
4794                rangestart = -1;
4795            }
4796        }
4797
4798        if (o->flags & ANYOF_CLASS)
4799            for (i = 0; i < sizeof(anyofs)/sizeof(char*); i++)
4800                if (ANYOF_CLASS_TEST(o,i))
4801                    sv_catpv(sv, anyofs[i]);
4802
4803        if (flags & ANYOF_UNICODE)
4804            sv_catpv(sv, "{unicode}");
4805        else if (flags & ANYOF_UNICODE_ALL)
4806            sv_catpv(sv, "{unicode_all}");
4807
4808        {
4809            SV *lv;
4810            SV *sw = regclass_swash(o, FALSE, &lv, 0);
4811       
4812            if (lv) {
4813                if (sw) {
4814                    U8 s[UTF8_MAXLEN+1];
4815               
4816                    for (i = 0; i <= 256; i++) { /* just the first 256 */
4817                        U8 *e = uvchr_to_utf8(s, i);
4818                       
4819                        if (i < 256 && swash_fetch(sw, s, TRUE)) {
4820                            if (rangestart == -1)
4821                                rangestart = i;
4822                        } else if (rangestart != -1) {
4823                            U8 *p;
4824                       
4825                            if (i <= rangestart + 3)
4826                                for (; rangestart < i; rangestart++) {
4827                                    for(e = uvchr_to_utf8(s, rangestart), p = s; p < e; p++)
4828                                        put_byte(sv, *p);
4829                                }
4830                            else {
4831                                for (e = uvchr_to_utf8(s, rangestart), p = s; p < e; p++)
4832                                    put_byte(sv, *p);
4833                                sv_catpv(sv, "-");
4834                                    for (e = uvchr_to_utf8(s, i - 1), p = s; p < e; p++)
4835                                        put_byte(sv, *p);
4836                                }
4837                                rangestart = -1;
4838                            }
4839                        }
4840                       
4841                    sv_catpv(sv, "..."); /* et cetera */
4842                }
4843
4844                {
4845                    char *s = savepv(SvPVX(lv));
4846                    char *origs = s;
4847               
4848                    while(*s && *s != '\n') s++;
4849               
4850                    if (*s == '\n') {
4851                        char *t = ++s;
4852                       
4853                        while (*s) {
4854                            if (*s == '\n')
4855                                *s = ' ';
4856                            s++;
4857                        }
4858                        if (s[-1] == ' ')
4859                            s[-1] = 0;
4860                       
4861                        sv_catpv(sv, t);
4862                    }
4863               
4864                    Safefree(origs);
4865                }
4866            }
4867        }
4868
4869        Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
4870    }
4871    else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
4872        Perl_sv_catpvf(aTHX_ sv, "[-%d]", o->flags);
4873#endif  /* DEBUGGING */
4874}
4875
4876SV *
4877Perl_re_intuit_string(pTHX_ regexp *prog)
4878{                               /* Assume that RE_INTUIT is set */
4879    DEBUG_r(
4880        {   STRLEN n_a;
4881            char *s = SvPV(prog->check_substr
4882                      ? prog->check_substr : prog->check_utf8, n_a);
4883
4884            if (!PL_colorset) reginitcolors();
4885            PerlIO_printf(Perl_debug_log,
4886                      "%sUsing REx %ssubstr:%s `%s%.60s%s%s'\n",
4887                      PL_colors[4],
4888                      prog->check_substr ? "" : "utf8 ",
4889                      PL_colors[5],PL_colors[0],
4890                      s,
4891                      PL_colors[1],
4892                      (strlen(s) > 60 ? "..." : ""));
4893        } );
4894
4895    return prog->check_substr ? prog->check_substr : prog->check_utf8;
4896}
4897
4898void
4899Perl_pregfree(pTHX_ struct regexp *r)
4900{
4901#ifdef DEBUGGING
4902    SV *dsv = PERL_DEBUG_PAD_ZERO(0);
4903#endif
4904
4905    if (!r || (--r->refcnt > 0))
4906        return;
4907    DEBUG_r({
4908         int len;
4909         char *s;
4910
4911         s = (r->reganch & ROPT_UTF8) ? pv_uni_display(dsv, (U8*)r->precomp,
4912                r->prelen, 60, UNI_DISPLAY_REGEX)
4913            : pv_display(dsv, r->precomp, r->prelen, 0, 60);
4914         len = SvCUR(dsv);
4915         if (!PL_colorset)
4916              reginitcolors();
4917         PerlIO_printf(Perl_debug_log,
4918                       "%sFreeing REx:%s `%s%*.*s%s%s'\n",
4919                       PL_colors[4],PL_colors[5],PL_colors[0],
4920                       len, len, s,
4921                       PL_colors[1],
4922                       len > 60 ? "..." : "");
4923    });
4924
4925    if (r->precomp)
4926        Safefree(r->precomp);
4927    if (r->offsets)             /* 20010421 MJD */
4928        Safefree(r->offsets);
4929    if (RX_MATCH_COPIED(r))
4930        Safefree(r->subbeg);
4931    if (r->substrs) {
4932        if (r->anchored_substr)
4933            SvREFCNT_dec(r->anchored_substr);
4934        if (r->anchored_utf8)
4935            SvREFCNT_dec(r->anchored_utf8);
4936        if (r->float_substr)
4937            SvREFCNT_dec(r->float_substr);
4938        if (r->float_utf8)
4939            SvREFCNT_dec(r->float_utf8);
4940        Safefree(r->substrs);
4941    }
4942    if (r->data) {
4943        int n = r->data->count;
4944        PAD* new_comppad = NULL;
4945        PAD* old_comppad;
4946
4947        while (--n >= 0) {
4948          /* If you add a ->what type here, update the comment in regcomp.h */
4949            switch (r->data->what[n]) {
4950            case 's':
4951                SvREFCNT_dec((SV*)r->data->data[n]);
4952                break;
4953            case 'f':
4954                Safefree(r->data->data[n]);
4955                break;
4956            case 'p':
4957                new_comppad = (AV*)r->data->data[n];
4958                break;
4959            case 'o':
4960                if (new_comppad == NULL)
4961                    Perl_croak(aTHX_ "panic: pregfree comppad");
4962                PAD_SAVE_LOCAL(old_comppad,
4963                    /* Watch out for global destruction's random ordering. */
4964                    (SvTYPE(new_comppad) == SVt_PVAV) ?
4965                                new_comppad : Null(PAD *)
4966                );
4967                if (!OpREFCNT_dec((OP_4tree*)r->data->data[n])) {
4968                    op_free((OP_4tree*)r->data->data[n]);
4969                }
4970
4971                PAD_RESTORE_LOCAL(old_comppad);
4972                SvREFCNT_dec((SV*)new_comppad);
4973                new_comppad = NULL;
4974                break;
4975            case 'n':
4976                break;
4977            default:
4978                Perl_croak(aTHX_ "panic: regfree data code '%c'", r->data->what[n]);
4979            }
4980        }
4981        Safefree(r->data->what);
4982        Safefree(r->data);
4983    }
4984    Safefree(r->startp);
4985    Safefree(r->endp);
4986    Safefree(r);
4987}
4988
4989/*
4990 - regnext - dig the "next" pointer out of a node
4991 *
4992 * [Note, when REGALIGN is defined there are two places in regmatch()
4993 * that bypass this code for speed.]
4994 */
4995regnode *
4996Perl_regnext(pTHX_ register regnode *p)
4997{
4998    register I32 offset;
4999
5000    if (p == &PL_regdummy)
5001        return(NULL);
5002
5003    offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
5004    if (offset == 0)
5005        return(NULL);
5006
5007    return(p+offset);
5008}
5009
5010STATIC void     
5011S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
5012{
5013    va_list args;
5014    STRLEN l1 = strlen(pat1);
5015    STRLEN l2 = strlen(pat2);
5016    char buf[512];
5017    SV *msv;
5018    char *message;
5019
5020    if (l1 > 510)
5021        l1 = 510;
5022    if (l1 + l2 > 510)
5023        l2 = 510 - l1;
5024    Copy(pat1, buf, l1 , char);
5025    Copy(pat2, buf + l1, l2 , char);
5026    buf[l1 + l2] = '\n';
5027    buf[l1 + l2 + 1] = '\0';
5028#ifdef I_STDARG
5029    /* ANSI variant takes additional second argument */
5030    va_start(args, pat2);
5031#else
5032    va_start(args);
5033#endif
5034    msv = vmess(buf, &args);
5035    va_end(args);
5036    message = SvPV(msv,l1);
5037    if (l1 > 512)
5038        l1 = 512;
5039    Copy(message, buf, l1 , char);
5040    buf[l1-1] = '\0';                   /* Overwrite \n */
5041    Perl_croak(aTHX_ "%s", buf);
5042}
5043
5044/* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
5045
5046void
5047Perl_save_re_context(pTHX)
5048{
5049    SAVEI32(PL_reg_flags);              /* from regexec.c */
5050    SAVEPPTR(PL_bostr);
5051    SAVEPPTR(PL_reginput);              /* String-input pointer. */
5052    SAVEPPTR(PL_regbol);                /* Beginning of input, for ^ check. */
5053    SAVEPPTR(PL_regeol);                /* End of input, for $ check. */
5054    SAVEVPTR(PL_regstartp);             /* Pointer to startp array. */
5055    SAVEVPTR(PL_regendp);               /* Ditto for endp. */
5056    SAVEVPTR(PL_reglastparen);          /* Similarly for lastparen. */
5057    SAVEVPTR(PL_reglastcloseparen);     /* Similarly for lastcloseparen. */
5058    SAVEPPTR(PL_regtill);               /* How far we are required to go. */
5059    SAVEGENERICPV(PL_reg_start_tmp);            /* from regexec.c */
5060    PL_reg_start_tmp = 0;
5061    SAVEI32(PL_reg_start_tmpl);         /* from regexec.c */
5062    PL_reg_start_tmpl = 0;
5063    SAVEVPTR(PL_regdata);
5064    SAVEI32(PL_reg_eval_set);           /* from regexec.c */
5065    SAVEI32(PL_regnarrate);             /* from regexec.c */
5066    SAVEVPTR(PL_regprogram);            /* from regexec.c */
5067    SAVEINT(PL_regindent);              /* from regexec.c */
5068    SAVEVPTR(PL_regcc);                 /* from regexec.c */
5069    SAVEVPTR(PL_curcop);
5070    SAVEVPTR(PL_reg_call_cc);           /* from regexec.c */
5071    SAVEVPTR(PL_reg_re);                /* from regexec.c */
5072    SAVEPPTR(PL_reg_ganch);             /* from regexec.c */
5073    SAVESPTR(PL_reg_sv);                /* from regexec.c */
5074    SAVEBOOL(PL_reg_match_utf8);        /* from regexec.c */
5075    SAVEVPTR(PL_reg_magic);             /* from regexec.c */
5076    SAVEI32(PL_reg_oldpos);                     /* from regexec.c */
5077    SAVEVPTR(PL_reg_oldcurpm);          /* from regexec.c */
5078    SAVEVPTR(PL_reg_curpm);             /* from regexec.c */
5079    SAVEPPTR(PL_reg_oldsaved);          /* old saved substr during match */
5080    PL_reg_oldsaved = Nullch;
5081    SAVEI32(PL_reg_oldsavedlen);        /* old length of saved substr during match */
5082    PL_reg_oldsavedlen = 0;
5083    SAVEI32(PL_reg_maxiter);            /* max wait until caching pos */
5084    PL_reg_maxiter = 0;
5085    SAVEI32(PL_reg_leftiter);           /* wait until caching pos */
5086    PL_reg_leftiter = 0;
5087    SAVEGENERICPV(PL_reg_poscache);     /* cache of pos of WHILEM */
5088    PL_reg_poscache = Nullch;
5089    SAVEI32(PL_reg_poscache_size);      /* size of pos cache of WHILEM */
5090    PL_reg_poscache_size = 0;
5091    SAVEPPTR(PL_regprecomp);            /* uncompiled string. */
5092    SAVEI32(PL_regnpar);                /* () count. */
5093    SAVEI32(PL_regsize);                /* from regexec.c */
5094
5095    {
5096        /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
5097        U32 i;
5098        GV *mgv;
5099        REGEXP *rx;
5100        char digits[16];
5101
5102        if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
5103            for (i = 1; i <= rx->nparens; i++) {
5104                sprintf(digits, "%lu", (long)i);
5105                if ((mgv = gv_fetchpv(digits, FALSE, SVt_PV)))
5106                    save_scalar(mgv);
5107            }
5108        }
5109    }
5110
5111#ifdef DEBUGGING
5112    SAVEPPTR(PL_reg_starttry);          /* from regexec.c */
5113#endif
5114}
5115
5116static void
5117clear_re(pTHX_ void *r)
5118{
5119    ReREFCNT_dec((regexp *)r);
5120}
5121
Note: See TracBrowser for help on using the repository browser.