5 * "A fair jaw-cracker dwarf-language must be." --Samwise Gamgee
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!
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.
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.
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
27 /* need access to debugger hooks */
28 # if defined(PERL_EXT_RE_DEBUG) && !defined(DEBUGGING)
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
45 # define PERL_NO_GET_CONTEXT
50 * pregcomp and pregexec -- regsub and regerror are not used in perl
52 * Copyright (c) 1986 by University of Toronto.
53 * Written by Henry Spencer. Not derived from licensed software.
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:
59 * 1. The author is not responsible for the consequences of use of
60 * this software, no matter how awful, even if they arise
63 * 2. The origin of this software must not be misrepresented, either
64 * by explicit claim or by omission.
66 * 3. Altered versions must be plainly marked as such, and must not
67 * be misrepresented as being the original software.
70 **** Alterations to Henry's code are...
72 **** Copyright (c) 1991-2002, Larry Wall
74 **** You may distribute under the terms of either the GNU General Public
75 **** License or the Artistic License, as specified in the README file.
78 * Beware that some of this code is subtly aware of the way operator
79 * precedence is structured in regular expressions. Serious changes in
80 * regular-expression syntax might require a total rethink.
83 #define PERL_IN_REGCOMP_C
86 #ifndef PERL_IN_XSUB_RE
98 # if defined(BUGGY_MSC6)
99 /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
100 # pragma optimize("a",off)
101 /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
102 # pragma optimize("w",on )
103 # endif /* BUGGY_MSC6 */
107 #define STATIC static
110 typedef struct RExC_state_t {
111 U16 flags16; /* are we folding, multilining? */
112 char *precomp; /* uncompiled string. */
114 char *start; /* Start of input for compile */
115 char *end; /* End of input for compile */
116 char *parse; /* Input-scan pointer. */
117 I32 whilem_seen; /* number of WHILEM in this expr */
118 regnode *emit_start; /* Start of emitted-code area */
119 regnode *emit; /* Code-emit pointer; ®dummy = don't = compiling */
120 I32 naughty; /* How bad is this pattern? */
121 I32 sawback; /* Did we see \1, ...? */
123 I32 size; /* Code size. */
124 I32 npar; /* () count. */
130 char *starttry; /* -Dr: where regtry was called. */
131 #define RExC_starttry (pRExC_state->starttry)
135 #define RExC_flags16 (pRExC_state->flags16)
136 #define RExC_precomp (pRExC_state->precomp)
137 #define RExC_rx (pRExC_state->rx)
138 #define RExC_start (pRExC_state->start)
139 #define RExC_end (pRExC_state->end)
140 #define RExC_parse (pRExC_state->parse)
141 #define RExC_whilem_seen (pRExC_state->whilem_seen)
142 #define RExC_offsets (pRExC_state->rx->offsets) /* I am not like the others */
143 #define RExC_emit (pRExC_state->emit)
144 #define RExC_emit_start (pRExC_state->emit_start)
145 #define RExC_naughty (pRExC_state->naughty)
146 #define RExC_sawback (pRExC_state->sawback)
147 #define RExC_seen (pRExC_state->seen)
148 #define RExC_size (pRExC_state->size)
149 #define RExC_npar (pRExC_state->npar)
150 #define RExC_extralen (pRExC_state->extralen)
151 #define RExC_seen_zerolen (pRExC_state->seen_zerolen)
152 #define RExC_seen_evals (pRExC_state->seen_evals)
153 #define RExC_utf8 (pRExC_state->utf8)
155 #define ISMULT1(c) ((c) == '*' || (c) == '+' || (c) == '?')
156 #define ISMULT2(s) ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
157 ((*s) == '{' && regcurly(s)))
160 #undef SPSTART /* dratted cpp namespace... */
163 * Flags to be passed up and down.
165 #define WORST 0 /* Worst case. */
166 #define HASWIDTH 0x1 /* Known to match non-null strings. */
167 #define SIMPLE 0x2 /* Simple enough to be STAR/PLUS operand. */
168 #define SPSTART 0x4 /* Starts with * or +. */
169 #define TRYAGAIN 0x8 /* Weeded out a declaration. */
171 /* Length of a variant. */
173 typedef struct scan_data_t {
179 I32 last_end; /* min value, <0 unless valid. */
182 SV **longest; /* Either &l_fixed, or &l_float. */
186 I32 offset_float_min;
187 I32 offset_float_max;
191 struct regnode_charclass_class *start_class;
195 * Forward declarations for pregcomp()'s friends.
198 static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
201 #define SF_BEFORE_EOL (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
202 #define SF_BEFORE_SEOL 0x1
203 #define SF_BEFORE_MEOL 0x2
204 #define SF_FIX_BEFORE_EOL (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
205 #define SF_FL_BEFORE_EOL (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
208 # define SF_FIX_SHIFT_EOL (0+2)
209 # define SF_FL_SHIFT_EOL (0+4)
211 # define SF_FIX_SHIFT_EOL (+2)
212 # define SF_FL_SHIFT_EOL (+4)
215 #define SF_FIX_BEFORE_SEOL (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
216 #define SF_FIX_BEFORE_MEOL (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
218 #define SF_FL_BEFORE_SEOL (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
219 #define SF_FL_BEFORE_MEOL (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
220 #define SF_IS_INF 0x40
221 #define SF_HAS_PAR 0x80
222 #define SF_IN_PAR 0x100
223 #define SF_HAS_EVAL 0x200
224 #define SCF_DO_SUBSTR 0x400
225 #define SCF_DO_STCLASS_AND 0x0800
226 #define SCF_DO_STCLASS_OR 0x1000
227 #define SCF_DO_STCLASS (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
228 #define SCF_WHILEM_VISITED_POS 0x2000
230 #define UTF RExC_utf8
231 #define LOC (RExC_flags16 & PMf_LOCALE)
232 #define FOLD (RExC_flags16 & PMf_FOLD)
234 #define OOB_UNICODE 12345678
235 #define OOB_NAMEDCLASS -1
237 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
238 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
241 /* length of regex to show in messages that don't mark a position within */
242 #define RegexLengthToShowInErrorMessages 127
245 * If MARKER[12] are adjusted, be sure to adjust the constants at the top
246 * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
247 * op/pragma/warn/regcomp.
249 #define MARKER1 "<-- HERE" /* marker as it appears in the description */
250 #define MARKER2 " <-- HERE " /* marker as it appears within the regex */
252 #define REPORT_LOCATION " in regex; marked by " MARKER1 " in m/%.*s" MARKER2 "%s/"
255 * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
256 * arg. Show regex, up to a maximum length. If it's too long, chop and add
261 char *ellipses = ""; \
262 IV len = RExC_end - RExC_precomp; \
265 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \
267 if (len > RegexLengthToShowInErrorMessages) { \
268 /* chop 10 shorter than the max, to ensure meaning of "..." */ \
269 len = RegexLengthToShowInErrorMessages - 10; \
272 Perl_croak(aTHX_ "%s in regex m/%.*s%s/", \
273 msg, (int)len, RExC_precomp, ellipses); \
277 * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
278 * args. Show regex, up to a maximum length. If it's too long, chop and add
281 #define FAIL2(pat,msg) \
283 char *ellipses = ""; \
284 IV len = RExC_end - RExC_precomp; \
287 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \
289 if (len > RegexLengthToShowInErrorMessages) { \
290 /* chop 10 shorter than the max, to ensure meaning of "..." */ \
291 len = RegexLengthToShowInErrorMessages - 10; \
294 S_re_croak2(aTHX_ pat, " in regex m/%.*s%s/", \
295 msg, (int)len, RExC_precomp, ellipses); \
300 * Simple_vFAIL -- like FAIL, but marks the current location in the scan
302 #define Simple_vFAIL(m) \
304 IV offset = RExC_parse - RExC_precomp; \
306 Perl_croak(aTHX_ "%s" REPORT_LOCATION, \
307 m, (int)offset, RExC_precomp, RExC_precomp + offset); \
311 * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
316 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \
321 * Like Simple_vFAIL(), but accepts two arguments.
323 #define Simple_vFAIL2(m,a1) \
325 IV offset = RExC_parse - RExC_precomp; \
327 S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, \
328 (int)offset, RExC_precomp, RExC_precomp + offset); \
332 * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
334 #define vFAIL2(m,a1) \
337 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \
338 Simple_vFAIL2(m, a1); \
343 * Like Simple_vFAIL(), but accepts three arguments.
345 #define Simple_vFAIL3(m, a1, a2) \
347 IV offset = RExC_parse - RExC_precomp; \
349 S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, \
350 (int)offset, RExC_precomp, RExC_precomp + offset); \
354 * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
356 #define vFAIL3(m,a1,a2) \
359 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \
360 Simple_vFAIL3(m, a1, a2); \
364 * Like Simple_vFAIL(), but accepts four arguments.
366 #define Simple_vFAIL4(m, a1, a2, a3) \
368 IV offset = RExC_parse - RExC_precomp; \
370 S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3,\
371 (int)offset, RExC_precomp, RExC_precomp + offset); \
375 * Like Simple_vFAIL(), but accepts five arguments.
377 #define Simple_vFAIL5(m, a1, a2, a3, a4) \
379 IV offset = RExC_parse - RExC_precomp; \
380 S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3, a4,\
381 (int)offset, RExC_precomp, RExC_precomp + offset); \
385 #define vWARN(loc,m) \
387 IV offset = loc - RExC_precomp; \
388 Perl_warner(aTHX_ WARN_REGEXP, "%s" REPORT_LOCATION,\
389 m, (int)offset, RExC_precomp, RExC_precomp + offset); \
392 #define vWARNdep(loc,m) \
394 IV offset = loc - RExC_precomp; \
395 int warn_cat = ckWARN(WARN_REGEXP) ? WARN_REGEXP : WARN_DEPRECATED; \
396 Perl_warner(aTHX_ warn_cat, "%s" REPORT_LOCATION,\
397 m, (int)offset, RExC_precomp, RExC_precomp + offset); \
401 #define vWARN2(loc, m, a1) \
403 IV offset = loc - RExC_precomp; \
404 Perl_warner(aTHX_ WARN_REGEXP, m REPORT_LOCATION,\
406 (int)offset, RExC_precomp, RExC_precomp + offset); \
409 #define vWARN3(loc, m, a1, a2) \
411 IV offset = loc - RExC_precomp; \
412 Perl_warner(aTHX_ WARN_REGEXP, m REPORT_LOCATION, \
414 (int)offset, RExC_precomp, RExC_precomp + offset); \
417 #define vWARN4(loc, m, a1, a2, a3) \
419 IV offset = loc - RExC_precomp; \
420 Perl_warner(aTHX_ WARN_REGEXP, m REPORT_LOCATION,\
422 (int)offset, RExC_precomp, RExC_precomp + offset); \
425 /* used for the parse_flags section for (?c) -- japhy */
426 #define vWARN5(loc, m, a1, a2, a3, a4) \
428 IV offset = loc - RExC_precomp; \
429 Perl_warner(aTHX_ WARN_REGEXP, m REPORT_LOCATION, \
431 (int)offset, RExC_precomp, RExC_precomp + offset); \
435 /* Allow for side effects in s */
436 #define REGC(c,s) STMT_START { if (!SIZE_ONLY) *(s) = (c); else (void)(s);} STMT_END
438 /* Macros for recording node offsets. 20001227 mjd@plover.com
439 * Nodes are numbered 1, 2, 3, 4. Node #n's position is recorded in
440 * element 2*n-1 of the array. Element #2n holds the byte length node #n.
441 * Element 0 holds the number n.
444 #define MJD_OFFSET_DEBUG(x)
445 /* #define MJD_OFFSET_DEBUG(x) fprintf x */
448 # define Set_Node_Offset_To_R(node,byte) \
452 Perl_croak(aTHX_ "value of node is %d in Offset macro", node); \
454 RExC_offsets[2*(node)-1] = (byte); \
459 # define Set_Node_Offset(node,byte) Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
460 # define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
462 # define Set_Node_Length_To_R(node,len) \
465 MJD_OFFSET_DEBUG((stderr, "** (%d) size of node %d is %d.\n", __LINE__, (node), (len))); \
467 Perl_croak(aTHX_ "value of node is %d in Length macro", node); \
469 RExC_offsets[2*(node)] = (len); \
474 # define Set_Node_Length(node,len) Set_Node_Length_To_R((node)-RExC_emit_start, len)
475 # define Set_Cur_Node_Length(len) Set_Node_Length(RExC_emit, len)
476 # define Set_Node_Cur_Length(node) Set_Node_Length(node, RExC_parse - parse_start)
478 /* Get offsets and lengths */
479 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
480 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
482 static void clear_re(pTHX_ void *r);
484 /* Mark that we cannot extend a found fixed substring at this point.
485 Updata the longest found anchored substring and the longest found
486 floating substrings if needed. */
489 S_scan_commit(pTHX_ RExC_state_t *pRExC_state, scan_data_t *data)
491 STRLEN l = CHR_SVLEN(data->last_found);
492 STRLEN old_l = CHR_SVLEN(*data->longest);
494 if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
495 sv_setsv(*data->longest, data->last_found);
496 if (*data->longest == data->longest_fixed) {
497 data->offset_fixed = l ? data->last_start_min : data->pos_min;
498 if (data->flags & SF_BEFORE_EOL)
500 |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
502 data->flags &= ~SF_FIX_BEFORE_EOL;
505 data->offset_float_min = l ? data->last_start_min : data->pos_min;
506 data->offset_float_max = (l
507 ? data->last_start_max
508 : data->pos_min + data->pos_delta);
509 if (data->flags & SF_BEFORE_EOL)
511 |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
513 data->flags &= ~SF_FL_BEFORE_EOL;
516 SvCUR_set(data->last_found, 0);
518 data->flags &= ~SF_BEFORE_EOL;
521 /* Can match anything (initialization) */
523 S_cl_anything(pTHX_ RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
525 ANYOF_CLASS_ZERO(cl);
526 ANYOF_BITMAP_SETALL(cl);
527 cl->flags = ANYOF_EOS|ANYOF_UNICODE_ALL;
529 cl->flags |= ANYOF_LOCALE;
532 /* Can match anything (initialization) */
534 S_cl_is_anything(pTHX_ struct regnode_charclass_class *cl)
538 for (value = 0; value <= ANYOF_MAX; value += 2)
539 if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
541 if (!(cl->flags & ANYOF_UNICODE_ALL))
543 if (!ANYOF_BITMAP_TESTALLSET(cl))
548 /* Can match anything (initialization) */
550 S_cl_init(pTHX_ RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
552 Zero(cl, 1, struct regnode_charclass_class);
554 cl_anything(pRExC_state, cl);
558 S_cl_init_zero(pTHX_ RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
560 Zero(cl, 1, struct regnode_charclass_class);
562 cl_anything(pRExC_state, cl);
564 cl->flags |= ANYOF_LOCALE;
567 /* 'And' a given class with another one. Can create false positives */
568 /* We assume that cl is not inverted */
570 S_cl_and(pTHX_ struct regnode_charclass_class *cl,
571 struct regnode_charclass_class *and_with)
573 if (!(and_with->flags & ANYOF_CLASS)
574 && !(cl->flags & ANYOF_CLASS)
575 && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
576 && !(and_with->flags & ANYOF_FOLD)
577 && !(cl->flags & ANYOF_FOLD)) {
580 if (and_with->flags & ANYOF_INVERT)
581 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
582 cl->bitmap[i] &= ~and_with->bitmap[i];
584 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
585 cl->bitmap[i] &= and_with->bitmap[i];
586 } /* XXXX: logic is complicated otherwise, leave it along for a moment. */
587 if (!(and_with->flags & ANYOF_EOS))
588 cl->flags &= ~ANYOF_EOS;
590 if (cl->flags & ANYOF_UNICODE_ALL && and_with->flags & ANYOF_UNICODE) {
591 cl->flags &= ~ANYOF_UNICODE_ALL;
592 cl->flags |= ANYOF_UNICODE;
593 ARG_SET(cl, ARG(and_with));
595 if (!(and_with->flags & ANYOF_UNICODE_ALL))
596 cl->flags &= ~ANYOF_UNICODE_ALL;
597 if (!(and_with->flags & (ANYOF_UNICODE|ANYOF_UNICODE_ALL)))
598 cl->flags &= ~ANYOF_UNICODE;
601 /* 'OR' a given class with another one. Can create false positives */
602 /* We assume that cl is not inverted */
604 S_cl_or(pTHX_ RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, struct regnode_charclass_class *or_with)
606 if (or_with->flags & ANYOF_INVERT) {
608 * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2))
609 * <= (B1 | !B2) | (CL1 | !CL2)
610 * which is wasteful if CL2 is small, but we ignore CL2:
611 * (B1 | CL1) | (!B2 & !CL2) <= (B1 | CL1) | !B2 = (B1 | !B2) | CL1
612 * XXXX Can we handle case-fold? Unclear:
613 * (OK1(i) | OK1(i')) | !(OK1(i) | OK1(i')) =
614 * (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i'))
616 if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
617 && !(or_with->flags & ANYOF_FOLD)
618 && !(cl->flags & ANYOF_FOLD) ) {
621 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
622 cl->bitmap[i] |= ~or_with->bitmap[i];
623 } /* XXXX: logic is complicated otherwise */
625 cl_anything(pRExC_state, cl);
628 /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
629 if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
630 && (!(or_with->flags & ANYOF_FOLD)
631 || (cl->flags & ANYOF_FOLD)) ) {
634 /* OR char bitmap and class bitmap separately */
635 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
636 cl->bitmap[i] |= or_with->bitmap[i];
637 if (or_with->flags & ANYOF_CLASS) {
638 for (i = 0; i < ANYOF_CLASSBITMAP_SIZE; i++)
639 cl->classflags[i] |= or_with->classflags[i];
640 cl->flags |= ANYOF_CLASS;
643 else { /* XXXX: logic is complicated, leave it along for a moment. */
644 cl_anything(pRExC_state, cl);
647 if (or_with->flags & ANYOF_EOS)
648 cl->flags |= ANYOF_EOS;
650 if (cl->flags & ANYOF_UNICODE && or_with->flags & ANYOF_UNICODE &&
651 ARG(cl) != ARG(or_with)) {
652 cl->flags |= ANYOF_UNICODE_ALL;
653 cl->flags &= ~ANYOF_UNICODE;
655 if (or_with->flags & ANYOF_UNICODE_ALL) {
656 cl->flags |= ANYOF_UNICODE_ALL;
657 cl->flags &= ~ANYOF_UNICODE;
662 * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
663 * These need to be revisited when a newer toolchain becomes available.
665 #if defined(__sparc64__) && defined(__GNUC__)
666 # if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
667 # undef SPARC64_GCC_WORKAROUND
668 # define SPARC64_GCC_WORKAROUND 1
672 /* REx optimizer. Converts nodes into quickier variants "in place".
673 Finds fixed substrings. */
675 /* Stops at toplevel WHILEM as well as at `last'. At end *scanp is set
676 to the position after last scanned or to NULL. */
679 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, regnode *last, scan_data_t *data, U32 flags)
680 /* scanp: Start here (read-write). */
681 /* deltap: Write maxlen-minlen here. */
682 /* last: Stop before this one. */
684 I32 min = 0, pars = 0, code;
685 regnode *scan = *scanp, *next;
687 int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
688 int is_inf_internal = 0; /* The studied chunk is infinite */
689 I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
690 scan_data_t data_fake;
691 struct regnode_charclass_class and_with; /* Valid if flags & SCF_DO_STCLASS_OR */
693 while (scan && OP(scan) != END && scan < last) {
694 /* Peephole optimizer: */
696 if (PL_regkind[(U8)OP(scan)] == EXACT) {
697 /* Merge several consecutive EXACTish nodes into one. */
698 regnode *n = regnext(scan);
701 regnode *stop = scan;
704 next = scan + NODE_SZ_STR(scan);
705 /* Skip NOTHING, merge EXACT*. */
707 ( PL_regkind[(U8)OP(n)] == NOTHING ||
708 (stringok && (OP(n) == OP(scan))))
710 && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX) {
711 if (OP(n) == TAIL || n > next)
713 if (PL_regkind[(U8)OP(n)] == NOTHING) {
714 NEXT_OFF(scan) += NEXT_OFF(n);
715 next = n + NODE_STEP_REGNODE;
723 int oldl = STR_LEN(scan);
724 regnode *nnext = regnext(n);
726 if (oldl + STR_LEN(n) > U8_MAX)
728 NEXT_OFF(scan) += NEXT_OFF(n);
729 STR_LEN(scan) += STR_LEN(n);
730 next = n + NODE_SZ_STR(n);
731 /* Now we can overwrite *n : */
732 Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
740 if (UTF && OP(scan) == EXACTF && STR_LEN(scan) >= 6) {
742 Two problematic code points in Unicode casefolding of EXACT nodes:
744 U+0390 - GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
745 U+03B0 - GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
751 U+03B9 U+0308 U+0301 0xCE 0xB9 0xCC 0x88 0xCC 0x81
752 U+03C5 U+0308 U+0301 0xCF 0x85 0xCC 0x88 0xCC 0x81
754 This means that in case-insensitive matching (or "loose matching",
755 as Unicode calls it), an EXACTF of length six (the UTF-8 encoded byte
756 length of the above casefolded versions) can match a target string
757 of length two (the byte length of UTF-8 encoded U+0390 or U+03B0).
758 This would rather mess up the minimum length computation.
760 What we'll do is to look for the tail four bytes, and then peek
761 at the preceding two bytes to see whether we need to decrease
762 the minimum length by four (six minus two).
764 Thanks to the design of UTF-8, there cannot be false matches:
765 A sequence of valid UTF-8 bytes cannot be a subsequence of
766 another valid sequence of UTF-8 bytes.
769 char *s0 = STRING(scan), *s, *t;
770 char *s1 = s0 + STR_LEN(scan) - 1, *s2 = s1 - 4;
771 char *t0 = "\xcc\x88\xcc\x81";
775 s < s2 && (t = ninstr(s, s1, t0, t1));
777 if (((U8)t[-1] == 0xB9 && (U8)t[-2] == 0xCE) ||
778 ((U8)t[-1] == 0x85 && (U8)t[-2] == 0xCF))
785 n = scan + NODE_SZ_STR(scan);
787 if (PL_regkind[(U8)OP(n)] != NOTHING || OP(n) == NOTHING) {
795 /* Follow the next-chain of the current node and optimize
796 away all the NOTHINGs from it. */
797 if (OP(scan) != CURLYX) {
798 int max = (reg_off_by_arg[OP(scan)]
800 /* I32 may be smaller than U16 on CRAYs! */
801 : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
802 int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
806 /* Skip NOTHING and LONGJMP. */
807 while ((n = regnext(n))
808 && ((PL_regkind[(U8)OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
809 || ((OP(n) == LONGJMP) && (noff = ARG(n))))
812 if (reg_off_by_arg[OP(scan)])
815 NEXT_OFF(scan) = off;
817 /* The principal pseudo-switch. Cannot be a switch, since we
818 look into several different things. */
819 if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
820 || OP(scan) == IFTHEN || OP(scan) == SUSPEND) {
821 next = regnext(scan);
824 if (OP(next) == code || code == IFTHEN || code == SUSPEND) {
825 I32 max1 = 0, min1 = I32_MAX, num = 0;
826 struct regnode_charclass_class accum;
828 if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
829 scan_commit(pRExC_state, data); /* Cannot merge strings after this. */
830 if (flags & SCF_DO_STCLASS)
831 cl_init_zero(pRExC_state, &accum);
832 while (OP(scan) == code) {
833 I32 deltanext, minnext, f = 0, fake;
834 struct regnode_charclass_class this_class;
839 data_fake.whilem_c = data->whilem_c;
840 data_fake.last_closep = data->last_closep;
843 data_fake.last_closep = &fake;
844 next = regnext(scan);
845 scan = NEXTOPER(scan);
847 scan = NEXTOPER(scan);
848 if (flags & SCF_DO_STCLASS) {
849 cl_init(pRExC_state, &this_class);
850 data_fake.start_class = &this_class;
851 f = SCF_DO_STCLASS_AND;
853 if (flags & SCF_WHILEM_VISITED_POS)
854 f |= SCF_WHILEM_VISITED_POS;
855 /* we suppose the run is continuous, last=next...*/
856 minnext = study_chunk(pRExC_state, &scan, &deltanext,
857 next, &data_fake, f);
860 if (max1 < minnext + deltanext)
861 max1 = minnext + deltanext;
862 if (deltanext == I32_MAX)
863 is_inf = is_inf_internal = 1;
865 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
867 if (data && (data_fake.flags & SF_HAS_EVAL))
868 data->flags |= SF_HAS_EVAL;
870 data->whilem_c = data_fake.whilem_c;
871 if (flags & SCF_DO_STCLASS)
872 cl_or(pRExC_state, &accum, &this_class);
876 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
878 if (flags & SCF_DO_SUBSTR) {
879 data->pos_min += min1;
880 data->pos_delta += max1 - min1;
881 if (max1 != min1 || is_inf)
882 data->longest = &(data->longest_float);
885 delta += max1 - min1;
886 if (flags & SCF_DO_STCLASS_OR) {
887 cl_or(pRExC_state, data->start_class, &accum);
889 cl_and(data->start_class, &and_with);
890 flags &= ~SCF_DO_STCLASS;
893 else if (flags & SCF_DO_STCLASS_AND) {
895 cl_and(data->start_class, &accum);
896 flags &= ~SCF_DO_STCLASS;
899 /* Switch to OR mode: cache the old value of
900 * data->start_class */
901 StructCopy(data->start_class, &and_with,
902 struct regnode_charclass_class);
903 flags &= ~SCF_DO_STCLASS_AND;
904 StructCopy(&accum, data->start_class,
905 struct regnode_charclass_class);
906 flags |= SCF_DO_STCLASS_OR;
907 data->start_class->flags |= ANYOF_EOS;
911 else if (code == BRANCHJ) /* single branch is optimized. */
912 scan = NEXTOPER(NEXTOPER(scan));
913 else /* single branch is optimized. */
914 scan = NEXTOPER(scan);
917 else if (OP(scan) == EXACT) {
918 I32 l = STR_LEN(scan);
919 UV uc = *((U8*)STRING(scan));
921 U8 *s = (U8*)STRING(scan);
922 l = utf8_length(s, s + l);
923 uc = utf8_to_uvchr(s, NULL);
926 if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
927 /* The code below prefers earlier match for fixed
928 offset, later match for variable offset. */
929 if (data->last_end == -1) { /* Update the start info. */
930 data->last_start_min = data->pos_min;
931 data->last_start_max = is_inf
932 ? I32_MAX : data->pos_min + data->pos_delta;
934 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
935 data->last_end = data->pos_min + l;
936 data->pos_min += l; /* As in the first entry. */
937 data->flags &= ~SF_BEFORE_EOL;
939 if (flags & SCF_DO_STCLASS_AND) {
940 /* Check whether it is compatible with what we know already! */
944 (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
945 && !ANYOF_BITMAP_TEST(data->start_class, uc)
946 && (!(data->start_class->flags & ANYOF_FOLD)
947 || !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc])))
950 ANYOF_CLASS_ZERO(data->start_class);
951 ANYOF_BITMAP_ZERO(data->start_class);
953 ANYOF_BITMAP_SET(data->start_class, uc);
954 data->start_class->flags &= ~ANYOF_EOS;
956 data->start_class->flags &= ~ANYOF_UNICODE_ALL;
958 else if (flags & SCF_DO_STCLASS_OR) {
959 /* false positive possible if the class is case-folded */
961 ANYOF_BITMAP_SET(data->start_class, uc);
963 data->start_class->flags |= ANYOF_UNICODE_ALL;
964 data->start_class->flags &= ~ANYOF_EOS;
965 cl_and(data->start_class, &and_with);
967 flags &= ~SCF_DO_STCLASS;
969 else if (PL_regkind[(U8)OP(scan)] == EXACT) { /* But OP != EXACT! */
970 I32 l = STR_LEN(scan);
971 UV uc = *((U8*)STRING(scan));
973 /* Search for fixed substrings supports EXACT only. */
974 if (flags & SCF_DO_SUBSTR)
975 scan_commit(pRExC_state, data);
977 U8 *s = (U8 *)STRING(scan);
978 l = utf8_length(s, s + l);
979 uc = utf8_to_uvchr(s, NULL);
982 if (data && (flags & SCF_DO_SUBSTR))
984 if (flags & SCF_DO_STCLASS_AND) {
985 /* Check whether it is compatible with what we know already! */
989 (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
990 && !ANYOF_BITMAP_TEST(data->start_class, uc)
991 && !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc])))
993 ANYOF_CLASS_ZERO(data->start_class);
994 ANYOF_BITMAP_ZERO(data->start_class);
996 ANYOF_BITMAP_SET(data->start_class, uc);
997 data->start_class->flags &= ~ANYOF_EOS;
998 data->start_class->flags |= ANYOF_FOLD;
999 if (OP(scan) == EXACTFL)
1000 data->start_class->flags |= ANYOF_LOCALE;
1003 else if (flags & SCF_DO_STCLASS_OR) {
1004 if (data->start_class->flags & ANYOF_FOLD) {
1005 /* false positive possible if the class is case-folded.
1006 Assume that the locale settings are the same... */
1008 ANYOF_BITMAP_SET(data->start_class, uc);
1009 data->start_class->flags &= ~ANYOF_EOS;
1011 cl_and(data->start_class, &and_with);
1013 flags &= ~SCF_DO_STCLASS;
1015 else if (strchr((char*)PL_varies,OP(scan))) {
1016 I32 mincount, maxcount, minnext, deltanext, fl = 0;
1017 I32 f = flags, pos_before = 0;
1018 regnode *oscan = scan;
1019 struct regnode_charclass_class this_class;
1020 struct regnode_charclass_class *oclass = NULL;
1021 I32 next_is_eval = 0;
1023 switch (PL_regkind[(U8)OP(scan)]) {
1024 case WHILEM: /* End of (?:...)* . */
1025 scan = NEXTOPER(scan);
1028 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
1029 next = NEXTOPER(scan);
1030 if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
1032 maxcount = REG_INFTY;
1033 next = regnext(scan);
1034 scan = NEXTOPER(scan);
1038 if (flags & SCF_DO_SUBSTR)
1043 if (flags & SCF_DO_STCLASS) {
1045 maxcount = REG_INFTY;
1046 next = regnext(scan);
1047 scan = NEXTOPER(scan);
1050 is_inf = is_inf_internal = 1;
1051 scan = regnext(scan);
1052 if (flags & SCF_DO_SUBSTR) {
1053 scan_commit(pRExC_state, data); /* Cannot extend fixed substrings */
1054 data->longest = &(data->longest_float);
1056 goto optimize_curly_tail;
1058 mincount = ARG1(scan);
1059 maxcount = ARG2(scan);
1060 next = regnext(scan);
1061 if (OP(scan) == CURLYX) {
1062 I32 lp = (data ? *(data->last_closep) : 0);
1064 scan->flags = ((lp <= U8_MAX) ? lp : U8_MAX);
1066 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
1067 next_is_eval = (OP(scan) == EVAL);
1069 if (flags & SCF_DO_SUBSTR) {
1070 if (mincount == 0) scan_commit(pRExC_state,data); /* Cannot extend fixed substrings */
1071 pos_before = data->pos_min;
1075 data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
1077 data->flags |= SF_IS_INF;
1079 if (flags & SCF_DO_STCLASS) {
1080 cl_init(pRExC_state, &this_class);
1081 oclass = data->start_class;
1082 data->start_class = &this_class;
1083 f |= SCF_DO_STCLASS_AND;
1084 f &= ~SCF_DO_STCLASS_OR;
1086 /* These are the cases when once a subexpression
1087 fails at a particular position, it cannot succeed
1088 even after backtracking at the enclosing scope.
1090 XXXX what if minimal match and we are at the
1091 initial run of {n,m}? */
1092 if ((mincount != maxcount - 1) && (maxcount != REG_INFTY))
1093 f &= ~SCF_WHILEM_VISITED_POS;
1095 /* This will finish on WHILEM, setting scan, or on NULL: */
1096 minnext = study_chunk(pRExC_state, &scan, &deltanext, last, data,
1098 ? (f & ~SCF_DO_SUBSTR) : f);
1100 if (flags & SCF_DO_STCLASS)
1101 data->start_class = oclass;
1102 if (mincount == 0 || minnext == 0) {
1103 if (flags & SCF_DO_STCLASS_OR) {
1104 cl_or(pRExC_state, data->start_class, &this_class);
1106 else if (flags & SCF_DO_STCLASS_AND) {
1107 /* Switch to OR mode: cache the old value of
1108 * data->start_class */
1109 StructCopy(data->start_class, &and_with,
1110 struct regnode_charclass_class);
1111 flags &= ~SCF_DO_STCLASS_AND;
1112 StructCopy(&this_class, data->start_class,
1113 struct regnode_charclass_class);
1114 flags |= SCF_DO_STCLASS_OR;
1115 data->start_class->flags |= ANYOF_EOS;
1117 } else { /* Non-zero len */
1118 if (flags & SCF_DO_STCLASS_OR) {
1119 cl_or(pRExC_state, data->start_class, &this_class);
1120 cl_and(data->start_class, &and_with);
1122 else if (flags & SCF_DO_STCLASS_AND)
1123 cl_and(data->start_class, &this_class);
1124 flags &= ~SCF_DO_STCLASS;
1126 if (!scan) /* It was not CURLYX, but CURLY. */
1128 if (ckWARN(WARN_REGEXP)
1129 /* ? quantifier ok, except for (?{ ... }) */
1130 && (next_is_eval || !(mincount == 0 && maxcount == 1))
1131 && (minnext == 0) && (deltanext == 0)
1132 && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
1133 && maxcount <= REG_INFTY/3) /* Complement check for big count */
1136 "Quantifier unexpected on zero-length expression");
1139 min += minnext * mincount;
1140 is_inf_internal |= ((maxcount == REG_INFTY
1141 && (minnext + deltanext) > 0)
1142 || deltanext == I32_MAX);
1143 is_inf |= is_inf_internal;
1144 delta += (minnext + deltanext) * maxcount - minnext * mincount;
1146 /* Try powerful optimization CURLYX => CURLYN. */
1147 if ( OP(oscan) == CURLYX && data
1148 && data->flags & SF_IN_PAR
1149 && !(data->flags & SF_HAS_EVAL)
1150 && !deltanext && minnext == 1 ) {
1151 /* Try to optimize to CURLYN. */
1152 regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
1153 regnode *nxt1 = nxt;
1160 if (!strchr((char*)PL_simple,OP(nxt))
1161 && !(PL_regkind[(U8)OP(nxt)] == EXACT
1162 && STR_LEN(nxt) == 1))
1168 if (OP(nxt) != CLOSE)
1170 /* Now we know that nxt2 is the only contents: */
1171 oscan->flags = ARG(nxt);
1173 OP(nxt1) = NOTHING; /* was OPEN. */
1175 OP(nxt1 + 1) = OPTIMIZED; /* was count. */
1176 NEXT_OFF(nxt1+ 1) = 0; /* just for consistancy. */
1177 NEXT_OFF(nxt2) = 0; /* just for consistancy with CURLY. */
1178 OP(nxt) = OPTIMIZED; /* was CLOSE. */
1179 OP(nxt + 1) = OPTIMIZED; /* was count. */
1180 NEXT_OFF(nxt+ 1) = 0; /* just for consistancy. */
1185 /* Try optimization CURLYX => CURLYM. */
1186 if ( OP(oscan) == CURLYX && data
1187 && !(data->flags & SF_HAS_PAR)
1188 && !(data->flags & SF_HAS_EVAL)
1190 /* XXXX How to optimize if data == 0? */
1191 /* Optimize to a simpler form. */
1192 regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
1196 while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
1197 && (OP(nxt2) != WHILEM))
1199 OP(nxt2) = SUCCEED; /* Whas WHILEM */
1200 /* Need to optimize away parenths. */
1201 if (data->flags & SF_IN_PAR) {
1202 /* Set the parenth number. */
1203 regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
1205 if (OP(nxt) != CLOSE)
1206 FAIL("Panic opt close");
1207 oscan->flags = ARG(nxt);
1208 OP(nxt1) = OPTIMIZED; /* was OPEN. */
1209 OP(nxt) = OPTIMIZED; /* was CLOSE. */
1211 OP(nxt1 + 1) = OPTIMIZED; /* was count. */
1212 OP(nxt + 1) = OPTIMIZED; /* was count. */
1213 NEXT_OFF(nxt1 + 1) = 0; /* just for consistancy. */
1214 NEXT_OFF(nxt + 1) = 0; /* just for consistancy. */
1217 while ( nxt1 && (OP(nxt1) != WHILEM)) {
1218 regnode *nnxt = regnext(nxt1);
1221 if (reg_off_by_arg[OP(nxt1)])
1222 ARG_SET(nxt1, nxt2 - nxt1);
1223 else if (nxt2 - nxt1 < U16_MAX)
1224 NEXT_OFF(nxt1) = nxt2 - nxt1;
1226 OP(nxt) = NOTHING; /* Cannot beautify */
1231 /* Optimize again: */
1232 study_chunk(pRExC_state, &nxt1, &deltanext, nxt,
1238 else if ((OP(oscan) == CURLYX)
1239 && (flags & SCF_WHILEM_VISITED_POS)
1240 /* See the comment on a similar expression above.
1241 However, this time it not a subexpression
1242 we care about, but the expression itself. */
1243 && (maxcount == REG_INFTY)
1244 && data && ++data->whilem_c < 16) {
1245 /* This stays as CURLYX, we can put the count/of pair. */
1246 /* Find WHILEM (as in regexec.c) */
1247 regnode *nxt = oscan + NEXT_OFF(oscan);
1249 if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
1251 PREVOPER(nxt)->flags = data->whilem_c
1252 | (RExC_whilem_seen << 4); /* On WHILEM */
1254 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
1256 if (flags & SCF_DO_SUBSTR) {
1257 SV *last_str = Nullsv;
1258 int counted = mincount != 0;
1260 if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
1261 #if defined(SPARC64_GCC_WORKAROUND)
1267 if (pos_before >= data->last_start_min)
1270 b = data->last_start_min;
1273 s = SvPV(data->last_found, l);
1274 old = b - data->last_start_min;
1277 I32 b = pos_before >= data->last_start_min
1278 ? pos_before : data->last_start_min;
1280 char *s = SvPV(data->last_found, l);
1281 I32 old = b - data->last_start_min;
1285 old = utf8_hop((U8*)s, old) - (U8*)s;
1288 /* Get the added string: */
1289 last_str = newSVpvn(s + old, l);
1290 if (deltanext == 0 && pos_before == b) {
1291 /* What was added is a constant string */
1293 SvGROW(last_str, (mincount * l) + 1);
1294 repeatcpy(SvPVX(last_str) + l,
1295 SvPVX(last_str), l, mincount - 1);
1296 SvCUR(last_str) *= mincount;
1297 /* Add additional parts. */
1298 SvCUR_set(data->last_found,
1299 SvCUR(data->last_found) - l);
1300 sv_catsv(data->last_found, last_str);
1301 data->last_end += l * (mincount - 1);
1304 /* start offset must point into the last copy */
1305 data->last_start_min += minnext * (mincount - 1);
1306 data->last_start_max += is_inf ? 0 : (maxcount - 1)
1307 * (minnext + data->pos_delta);
1310 /* It is counted once already... */
1311 data->pos_min += minnext * (mincount - counted);
1312 data->pos_delta += - counted * deltanext +
1313 (minnext + deltanext) * maxcount - minnext * mincount;
1314 if (mincount != maxcount) {
1315 /* Cannot extend fixed substrings found inside
1317 scan_commit(pRExC_state,data);
1318 if (mincount && last_str) {
1319 sv_setsv(data->last_found, last_str);
1320 data->last_end = data->pos_min;
1321 data->last_start_min =
1322 data->pos_min - CHR_SVLEN(last_str);
1323 data->last_start_max = is_inf
1325 : data->pos_min + data->pos_delta
1326 - CHR_SVLEN(last_str);
1328 data->longest = &(data->longest_float);
1330 SvREFCNT_dec(last_str);
1332 if (data && (fl & SF_HAS_EVAL))
1333 data->flags |= SF_HAS_EVAL;
1334 optimize_curly_tail:
1335 if (OP(oscan) != CURLYX) {
1336 while (PL_regkind[(U8)OP(next = regnext(oscan))] == NOTHING
1338 NEXT_OFF(oscan) += NEXT_OFF(next);
1341 default: /* REF and CLUMP only? */
1342 if (flags & SCF_DO_SUBSTR) {
1343 scan_commit(pRExC_state,data); /* Cannot expect anything... */
1344 data->longest = &(data->longest_float);
1346 is_inf = is_inf_internal = 1;
1347 if (flags & SCF_DO_STCLASS_OR)
1348 cl_anything(pRExC_state, data->start_class);
1349 flags &= ~SCF_DO_STCLASS;
1353 else if (strchr((char*)PL_simple,OP(scan))) {
1356 if (flags & SCF_DO_SUBSTR) {
1357 scan_commit(pRExC_state,data);
1361 if (flags & SCF_DO_STCLASS) {
1362 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
1364 /* Some of the logic below assumes that switching
1365 locale on will only add false positives. */
1366 switch (PL_regkind[(U8)OP(scan)]) {
1370 /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
1371 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
1372 cl_anything(pRExC_state, data->start_class);
1375 if (OP(scan) == SANY)
1377 if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
1378 value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
1379 || (data->start_class->flags & ANYOF_CLASS));
1380 cl_anything(pRExC_state, data->start_class);
1382 if (flags & SCF_DO_STCLASS_AND || !value)
1383 ANYOF_BITMAP_CLEAR(data->start_class,'\n');
1386 if (flags & SCF_DO_STCLASS_AND)
1387 cl_and(data->start_class,
1388 (struct regnode_charclass_class*)scan);
1390 cl_or(pRExC_state, data->start_class,
1391 (struct regnode_charclass_class*)scan);
1394 if (flags & SCF_DO_STCLASS_AND) {
1395 if (!(data->start_class->flags & ANYOF_LOCALE)) {
1396 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
1397 for (value = 0; value < 256; value++)
1398 if (!isALNUM(value))
1399 ANYOF_BITMAP_CLEAR(data->start_class, value);
1403 if (data->start_class->flags & ANYOF_LOCALE)
1404 ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
1406 for (value = 0; value < 256; value++)
1408 ANYOF_BITMAP_SET(data->start_class, value);
1413 if (flags & SCF_DO_STCLASS_AND) {
1414 if (data->start_class->flags & ANYOF_LOCALE)
1415 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
1418 ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
1419 data->start_class->flags |= ANYOF_LOCALE;
1423 if (flags & SCF_DO_STCLASS_AND) {
1424 if (!(data->start_class->flags & ANYOF_LOCALE)) {
1425 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
1426 for (value = 0; value < 256; value++)
1428 ANYOF_BITMAP_CLEAR(data->start_class, value);
1432 if (data->start_class->flags & ANYOF_LOCALE)
1433 ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
1435 for (value = 0; value < 256; value++)
1436 if (!isALNUM(value))
1437 ANYOF_BITMAP_SET(data->start_class, value);
1442 if (flags & SCF_DO_STCLASS_AND) {
1443 if (data->start_class->flags & ANYOF_LOCALE)
1444 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
1447 data->start_class->flags |= ANYOF_LOCALE;
1448 ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
1452 if (flags & SCF_DO_STCLASS_AND) {
1453 if (!(data->start_class->flags & ANYOF_LOCALE)) {
1454 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
1455 for (value = 0; value < 256; value++)
1456 if (!isSPACE(value))
1457 ANYOF_BITMAP_CLEAR(data->start_class, value);
1461 if (data->start_class->flags & ANYOF_LOCALE)
1462 ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
1464 for (value = 0; value < 256; value++)
1466 ANYOF_BITMAP_SET(data->start_class, value);
1471 if (flags & SCF_DO_STCLASS_AND) {
1472 if (data->start_class->flags & ANYOF_LOCALE)
1473 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
1476 data->start_class->flags |= ANYOF_LOCALE;
1477 ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
1481 if (flags & SCF_DO_STCLASS_AND) {
1482 if (!(data->start_class->flags & ANYOF_LOCALE)) {
1483 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
1484 for (value = 0; value < 256; value++)
1486 ANYOF_BITMAP_CLEAR(data->start_class, value);
1490 if (data->start_class->flags & ANYOF_LOCALE)
1491 ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
1493 for (value = 0; value < 256; value++)
1494 if (!isSPACE(value))
1495 ANYOF_BITMAP_SET(data->start_class, value);
1500 if (flags & SCF_DO_STCLASS_AND) {
1501 if (data->start_class->flags & ANYOF_LOCALE) {
1502 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
1503 for (value = 0; value < 256; value++)
1504 if (!isSPACE(value))
1505 ANYOF_BITMAP_CLEAR(data->start_class, value);
1509 data->start_class->flags |= ANYOF_LOCALE;
1510 ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
1514 if (flags & SCF_DO_STCLASS_AND) {
1515 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT);
1516 for (value = 0; value < 256; value++)
1517 if (!isDIGIT(value))
1518 ANYOF_BITMAP_CLEAR(data->start_class, value);
1521 if (data->start_class->flags & ANYOF_LOCALE)
1522 ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT);
1524 for (value = 0; value < 256; value++)
1526 ANYOF_BITMAP_SET(data->start_class, value);
1531 if (flags & SCF_DO_STCLASS_AND) {
1532 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT);
1533 for (value = 0; value < 256; value++)
1535 ANYOF_BITMAP_CLEAR(data->start_class, value);
1538 if (data->start_class->flags & ANYOF_LOCALE)
1539 ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT);
1541 for (value = 0; value < 256; value++)
1542 if (!isDIGIT(value))
1543 ANYOF_BITMAP_SET(data->start_class, value);
1548 if (flags & SCF_DO_STCLASS_OR)
1549 cl_and(data->start_class, &and_with);
1550 flags &= ~SCF_DO_STCLASS;
1553 else if (PL_regkind[(U8)OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
1554 data->flags |= (OP(scan) == MEOL
1558 else if ( PL_regkind[(U8)OP(scan)] == BRANCHJ
1559 /* Lookbehind, or need to calculate parens/evals/stclass: */
1560 && (scan->flags || data || (flags & SCF_DO_STCLASS))
1561 && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
1562 /* Lookahead/lookbehind */
1563 I32 deltanext, minnext, fake = 0;
1565 struct regnode_charclass_class intrnl;
1568 data_fake.flags = 0;
1570 data_fake.whilem_c = data->whilem_c;
1571 data_fake.last_closep = data->last_closep;
1574 data_fake.last_closep = &fake;
1575 if ( flags & SCF_DO_STCLASS && !scan->flags
1576 && OP(scan) == IFMATCH ) { /* Lookahead */
1577 cl_init(pRExC_state, &intrnl);
1578 data_fake.start_class = &intrnl;
1579 f |= SCF_DO_STCLASS_AND;
1581 if (flags & SCF_WHILEM_VISITED_POS)
1582 f |= SCF_WHILEM_VISITED_POS;
1583 next = regnext(scan);
1584 nscan = NEXTOPER(NEXTOPER(scan));
1585 minnext = study_chunk(pRExC_state, &nscan, &deltanext, last, &data_fake, f);
1588 vFAIL("Variable length lookbehind not implemented");
1590 else if (minnext > U8_MAX) {
1591 vFAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
1593 scan->flags = minnext;
1595 if (data && data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
1597 if (data && (data_fake.flags & SF_HAS_EVAL))
1598 data->flags |= SF_HAS_EVAL;
1600 data->whilem_c = data_fake.whilem_c;
1601 if (f & SCF_DO_STCLASS_AND) {
1602 int was = (data->start_class->flags & ANYOF_EOS);
1604 cl_and(data->start_class, &intrnl);
1606 data->start_class->flags |= ANYOF_EOS;
1609 else if (OP(scan) == OPEN) {
1612 else if (OP(scan) == CLOSE) {
1613 if (ARG(scan) == is_par) {
1614 next = regnext(scan);
1616 if ( next && (OP(next) != WHILEM) && next < last)
1617 is_par = 0; /* Disable optimization */
1620 *(data->last_closep) = ARG(scan);
1622 else if (OP(scan) == EVAL) {
1624 data->flags |= SF_HAS_EVAL;
1626 else if (OP(scan) == LOGICAL && scan->flags == 2) { /* Embedded follows */
1627 if (flags & SCF_DO_SUBSTR) {
1628 scan_commit(pRExC_state,data);
1629 data->longest = &(data->longest_float);
1631 is_inf = is_inf_internal = 1;
1632 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
1633 cl_anything(pRExC_state, data->start_class);
1634 flags &= ~SCF_DO_STCLASS;
1636 /* Else: zero-length, ignore. */
1637 scan = regnext(scan);
1642 *deltap = is_inf_internal ? I32_MAX : delta;
1643 if (flags & SCF_DO_SUBSTR && is_inf)
1644 data->pos_delta = I32_MAX - data->pos_min;
1645 if (is_par > U8_MAX)
1647 if (is_par && pars==1 && data) {
1648 data->flags |= SF_IN_PAR;
1649 data->flags &= ~SF_HAS_PAR;
1651 else if (pars && data) {
1652 data->flags |= SF_HAS_PAR;
1653 data->flags &= ~SF_IN_PAR;
1655 if (flags & SCF_DO_STCLASS_OR)
1656 cl_and(data->start_class, &and_with);
1661 S_add_data(pTHX_ RExC_state_t *pRExC_state, I32 n, char *s)
1663 if (RExC_rx->data) {
1664 Renewc(RExC_rx->data,
1665 sizeof(*RExC_rx->data) + sizeof(void*) * (RExC_rx->data->count + n - 1),
1666 char, struct reg_data);
1667 Renew(RExC_rx->data->what, RExC_rx->data->count + n, U8);
1668 RExC_rx->data->count += n;
1671 Newc(1207, RExC_rx->data, sizeof(*RExC_rx->data) + sizeof(void*) * (n - 1),
1672 char, struct reg_data);
1673 New(1208, RExC_rx->data->what, n, U8);
1674 RExC_rx->data->count = n;
1676 Copy(s, RExC_rx->data->what + RExC_rx->data->count - n, n, U8);
1677 return RExC_rx->data->count - n;
1681 Perl_reginitcolors(pTHX)
1684 char *s = PerlEnv_getenv("PERL_RE_COLORS");
1687 PL_colors[0] = s = savepv(s);
1689 s = strchr(s, '\t');
1695 PL_colors[i] = s = "";
1699 PL_colors[i++] = "";
1706 - pregcomp - compile a regular expression into internal code
1708 * We can't allocate space until we know how big the compiled form will be,
1709 * but we can't compile it (and thus know how big it is) until we've got a
1710 * place to put the code. So we cheat: we compile it twice, once with code
1711 * generation turned off and size counting turned on, and once "for real".
1712 * This also means that we don't allocate space until we are sure that the
1713 * thing really will compile successfully, and we never have to move the
1714 * code and thus invalidate pointers into it. (Note that it has to be in
1715 * one piece because free() must be able to free it all.) [NB: not true in perl]
1717 * Beware that the optimization-preparation code in here knows about some
1718 * of the structure of the compiled regexp. [I'll say.]
1721 Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
1731 RExC_state_t RExC_state;
1732 RExC_state_t *pRExC_state = &RExC_state;
1735 FAIL("NULL regexp argument");
1737 RExC_utf8 = pm->op_pmdynflags & PMdf_CMP_UTF8;
1741 if (!PL_colorset) reginitcolors();
1742 PerlIO_printf(Perl_debug_log, "%sCompiling REx%s `%s%*s%s'\n",
1743 PL_colors[4],PL_colors[5],PL_colors[0],
1744 (int)(xend - exp), RExC_precomp, PL_colors[1]);
1746 RExC_flags16 = pm->op_pmflags;
1750 RExC_seen_zerolen = *exp == '^' ? -1 : 0;
1751 RExC_seen_evals = 0;
1754 /* First pass: determine size, legality. */
1761 RExC_emit = &PL_regdummy;
1762 RExC_whilem_seen = 0;
1763 #if 0 /* REGC() is (currently) a NOP at the first pass.
1764 * Clever compilers notice this and complain. --jhi */
1765 REGC((U8)REG_MAGIC, (char*)RExC_emit);
1767 if (reg(pRExC_state, 0, &flags) == NULL) {
1768 RExC_precomp = Nullch;
1771 DEBUG_r(PerlIO_printf(Perl_debug_log, "size %"IVdf" ", (IV)RExC_size));
1773 /* Small enough for pointer-storage convention?
1774 If extralen==0, this means that we will not need long jumps. */
1775 if (RExC_size >= 0x10000L && RExC_extralen)
1776 RExC_size += RExC_extralen;
1779 if (RExC_whilem_seen > 15)
1780 RExC_whilem_seen = 15;
1782 /* Allocate space and initialize. */
1783 Newc(1001, r, sizeof(regexp) + (unsigned)RExC_size * sizeof(regnode),
1786 FAIL("Regexp out of space");
1789 /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
1790 Zero(r, sizeof(regexp) + (unsigned)RExC_size * sizeof(regnode), char);
1793 r->prelen = xend - exp;
1794 r->precomp = savepvn(RExC_precomp, r->prelen);
1796 r->reganch = pm->op_pmflags & PMf_COMPILETIME;
1797 r->nparens = RExC_npar - 1; /* set early to validate backrefs */
1799 r->substrs = 0; /* Useful during FAIL. */
1800 r->startp = 0; /* Useful during FAIL. */
1801 r->endp = 0; /* Useful during FAIL. */
1803 Newz(1304, r->offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
1805 r->offsets[0] = RExC_size;
1807 DEBUG_r(PerlIO_printf(Perl_debug_log,
1808 "%s %"UVuf" bytes for offset annotations.\n",
1809 r->offsets ? "Got" : "Couldn't get",
1810 (UV)((2*RExC_size+1) * sizeof(U32))));
1814 /* Second pass: emit code. */
1815 RExC_flags16 = pm->op_pmflags; /* don't let top level (?i) bleed */
1820 RExC_emit_start = r->program;
1821 RExC_emit = r->program;
1822 /* Store the count of eval-groups for security checks: */
1823 RExC_emit->next_off = ((RExC_seen_evals > U16_MAX) ? U16_MAX : RExC_seen_evals);
1824 REGC((U8)REG_MAGIC, (char*) RExC_emit++);
1826 if (reg(pRExC_state, 0, &flags) == NULL)
1829 /* Dig out information for optimizations. */
1830 r->reganch = pm->op_pmflags & PMf_COMPILETIME; /* Again? */
1831 pm->op_pmflags = RExC_flags16;
1833 r->reganch |= ROPT_UTF8; /* Unicode in it? */
1834 r->regstclass = NULL;
1835 if (RExC_naughty >= 10) /* Probably an expensive pattern. */
1836 r->reganch |= ROPT_NAUGHTY;
1837 scan = r->program + 1; /* First BRANCH. */
1839 /* XXXX To minimize changes to RE engine we always allocate
1840 3-units-long substrs field. */
1841 Newz(1004, r->substrs, 1, struct reg_substr_data);
1843 StructCopy(&zero_scan_data, &data, scan_data_t);
1844 /* XXXX Should not we check for something else? Usually it is OPEN1... */
1845 if (OP(scan) != BRANCH) { /* Only one top-level choice. */
1847 STRLEN longest_float_length, longest_fixed_length;
1848 struct regnode_charclass_class ch_class;
1853 /* Skip introductions and multiplicators >= 1. */
1854 while ((OP(first) == OPEN && (sawopen = 1)) ||
1855 /* An OR of *one* alternative - should not happen now. */
1856 (OP(first) == BRANCH && OP(regnext(first)) != BRANCH) ||
1857 (OP(first) == PLUS) ||
1858 (OP(first) == MINMOD) ||
1859 /* An {n,m} with n>0 */
1860 (PL_regkind[(U8)OP(first)] == CURLY && ARG1(first) > 0) ) {
1861 if (OP(first) == PLUS)
1864 first += regarglen[(U8)OP(first)];
1865 first = NEXTOPER(first);
1868 /* Starting-point info. */
1870 if (PL_regkind[(U8)OP(first)] == EXACT) {
1871 if (OP(first) == EXACT)
1872 ; /* Empty, get anchored substr later. */
1873 else if ((OP(first) == EXACTF || OP(first) == EXACTFL))
1874 r->regstclass = first;
1876 else if (strchr((char*)PL_simple,OP(first)))
1877 r->regstclass = first;
1878 else if (PL_regkind[(U8)OP(first)] == BOUND ||
1879 PL_regkind[(U8)OP(first)] == NBOUND)
1880 r->regstclass = first;
1881 else if (PL_regkind[(U8)OP(first)] == BOL) {
1882 r->reganch |= (OP(first) == MBOL
1884 : (OP(first) == SBOL
1887 first = NEXTOPER(first);
1890 else if (OP(first) == GPOS) {
1891 r->reganch |= ROPT_ANCH_GPOS;
1892 first = NEXTOPER(first);
1895 else if (!sawopen && (OP(first) == STAR &&
1896 PL_regkind[(U8)OP(NEXTOPER(first))] == REG_ANY) &&
1897 !(r->reganch & ROPT_ANCH) )
1899 /* turn .* into ^.* with an implied $*=1 */
1900 int type = OP(NEXTOPER(first));
1902 if (type == REG_ANY)
1903 type = ROPT_ANCH_MBOL;
1905 type = ROPT_ANCH_SBOL;
1907 r->reganch |= type | ROPT_IMPLICIT;
1908 first = NEXTOPER(first);
1911 if (sawplus && (!sawopen || !RExC_sawback)
1912 && !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */
1913 /* x+ must match at the 1st pos of run of x's */
1914 r->reganch |= ROPT_SKIP;
1916 /* Scan is after the zeroth branch, first is atomic matcher. */
1917 DEBUG_r(PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
1918 (IV)(first - scan + 1)));
1920 * If there's something expensive in the r.e., find the
1921 * longest literal string that must appear and make it the
1922 * regmust. Resolve ties in favor of later strings, since
1923 * the regstart check works with the beginning of the r.e.
1924 * and avoiding duplication strengthens checking. Not a
1925 * strong reason, but sufficient in the absence of others.
1926 * [Now we resolve ties in favor of the earlier string if
1927 * it happens that c_offset_min has been invalidated, since the
1928 * earlier string may buy us something the later one won't.]
1932 data.longest_fixed = newSVpvn("",0);
1933 data.longest_float = newSVpvn("",0);
1934 data.last_found = newSVpvn("",0);
1935 data.longest = &(data.longest_fixed);
1937 if (!r->regstclass) {
1938 cl_init(pRExC_state, &ch_class);
1939 data.start_class = &ch_class;
1940 stclass_flag = SCF_DO_STCLASS_AND;
1941 } else /* XXXX Check for BOUND? */
1943 data.last_closep = &last_close;
1945 minlen = study_chunk(pRExC_state, &first, &fake, scan + RExC_size, /* Up to end */
1946 &data, SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag);
1947 if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
1948 && data.last_start_min == 0 && data.last_end > 0
1949 && !RExC_seen_zerolen
1950 && (!(RExC_seen & REG_SEEN_GPOS) || (r->reganch & ROPT_ANCH_GPOS)))
1951 r->reganch |= ROPT_CHECK_ALL;
1952 scan_commit(pRExC_state, &data);
1953 SvREFCNT_dec(data.last_found);
1955 longest_float_length = CHR_SVLEN(data.longest_float);
1956 if (longest_float_length
1957 || (data.flags & SF_FL_BEFORE_EOL
1958 && (!(data.flags & SF_FL_BEFORE_MEOL)
1959 || (RExC_flags16 & PMf_MULTILINE)))) {
1962 if (SvCUR(data.longest_fixed) /* ok to leave SvCUR */
1963 && data.offset_fixed == data.offset_float_min
1964 && SvCUR(data.longest_fixed) == SvCUR(data.longest_float))
1965 goto remove_float; /* As in (a)+. */
1967 r->float_substr = data.longest_float;
1968 r->float_min_offset = data.offset_float_min;
1969 r->float_max_offset = data.offset_float_max;
1970 t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
1971 && (!(data.flags & SF_FL_BEFORE_MEOL)
1972 || (RExC_flags16 & PMf_MULTILINE)));
1973 fbm_compile(r->float_substr, t ? FBMcf_TAIL : 0);
1977 r->float_substr = Nullsv;
1978 SvREFCNT_dec(data.longest_float);
1979 longest_float_length = 0;
1982 longest_fixed_length = CHR_SVLEN(data.longest_fixed);
1983 if (longest_fixed_length
1984 || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
1985 && (!(data.flags & SF_FIX_BEFORE_MEOL)
1986 || (RExC_flags16 & PMf_MULTILINE)))) {
1989 r->anchored_substr = data.longest_fixed;
1990 r->anchored_offset = data.offset_fixed;
1991 t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
1992 && (!(data.flags & SF_FIX_BEFORE_MEOL)
1993 || (RExC_flags16 & PMf_MULTILINE)));
1994 fbm_compile(r->anchored_substr, t ? FBMcf_TAIL : 0);
1997 r->anchored_substr = Nullsv;
1998 SvREFCNT_dec(data.longest_fixed);
1999 longest_fixed_length = 0;
2002 && (OP(r->regstclass) == REG_ANY || OP(r->regstclass) == SANY))
2003 r->regstclass = NULL;
2004 if ((!r->anchored_substr || r->anchored_offset) && stclass_flag
2005 && !(data.start_class->flags & ANYOF_EOS)
2006 && !cl_is_anything(data.start_class)) {
2007 I32 n = add_data(pRExC_state, 1, "f");
2009 New(1006, RExC_rx->data->data[n], 1,
2010 struct regnode_charclass_class);
2011 StructCopy(data.start_class,
2012 (struct regnode_charclass_class*)RExC_rx->data->data[n],
2013 struct regnode_charclass_class);
2014 r->regstclass = (regnode*)RExC_rx->data->data[n];
2015 r->reganch &= ~ROPT_SKIP; /* Used in find_byclass(). */
2016 PL_regdata = r->data; /* for regprop() */
2017 DEBUG_r({ SV *sv = sv_newmortal();
2018 regprop(sv, (regnode*)data.start_class);
2019 PerlIO_printf(Perl_debug_log,
2020 "synthetic stclass `%s'.\n",
2024 /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
2025 if (longest_fixed_length > longest_float_length) {
2026 r->check_substr = r->anchored_substr;
2027 r->check_offset_min = r->check_offset_max = r->anchored_offset;
2028 if (r->reganch & ROPT_ANCH_SINGLE)
2029 r->reganch |= ROPT_NOSCAN;
2032 r->check_substr = r->float_substr;
2033 r->check_offset_min = data.offset_float_min;
2034 r->check_offset_max = data.offset_float_max;
2036 /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
2037 This should be changed ASAP! */
2038 if (r->check_substr && !(r->reganch & ROPT_ANCH_GPOS)) {
2039 r->reganch |= RE_USE_INTUIT;
2040 if (SvTAIL(r->check_substr))
2041 r->reganch |= RE_INTUIT_TAIL;
2045 /* Several toplevels. Best we can is to set minlen. */
2047 struct regnode_charclass_class ch_class;
2050 DEBUG_r(PerlIO_printf(Perl_debug_log, "\n"));
2051 scan = r->program + 1;
2052 cl_init(pRExC_state, &ch_class);
2053 data.start_class = &ch_class;
2054 data.last_closep = &last_close;
2055 minlen = study_chunk(pRExC_state, &scan, &fake, scan + RExC_size, &data, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS);
2056 r->check_substr = r->anchored_substr = r->float_substr = Nullsv;
2057 if (!(data.start_class->flags & ANYOF_EOS)
2058 && !cl_is_anything(data.start_class)) {
2059 I32 n = add_data(pRExC_state, 1, "f");
2061 New(1006, RExC_rx->data->data[n], 1,
2062 struct regnode_charclass_class);
2063 StructCopy(data.start_class,
2064 (struct regnode_charclass_class*)RExC_rx->data->data[n],
2065 struct regnode_charclass_class);
2066 r->regstclass = (regnode*)RExC_rx->data->data[n];
2067 r->reganch &= ~ROPT_SKIP; /* Used in find_byclass(). */
2068 DEBUG_r({ SV* sv = sv_newmortal();
2069 regprop(sv, (regnode*)data.start_class);
2070 PerlIO_printf(Perl_debug_log,
2071 "synthetic stclass `%s'.\n",
2077 if (RExC_seen & REG_SEEN_GPOS)
2078 r->reganch |= ROPT_GPOS_SEEN;
2079 if (RExC_seen & REG_SEEN_LOOKBEHIND)
2080 r->reganch |= ROPT_LOOKBEHIND_SEEN;
2081 if (RExC_seen & REG_SEEN_EVAL)
2082 r->reganch |= ROPT_EVAL_SEEN;
2083 if (RExC_seen & REG_SEEN_CANY)
2084 r->reganch |= ROPT_CANY_SEEN;
2085 Newz(1002, r->startp, RExC_npar, I32);
2086 Newz(1002, r->endp, RExC_npar, I32);
2087 PL_regdata = r->data; /* for regprop() */
2088 DEBUG_r(regdump(r));
2093 - reg - regular expression, i.e. main body or parenthesized thing
2095 * Caller must absorb opening parenthesis.
2097 * Combining parenthesis handling with the base level of regular expression
2098 * is a trifle forced, but the need to tie the tails of the branches to what
2099 * follows makes it hard to avoid.
2102 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp)
2103 /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
2105 register regnode *ret; /* Will be the head of the group. */
2106 register regnode *br;
2107 register regnode *lastbr;
2108 register regnode *ender = 0;
2109 register I32 parno = 0;
2110 I32 flags, oregflags = RExC_flags16, have_branch = 0, open = 0;
2112 /* for (?g), (?gc), and (?o) warnings; warning
2113 about (?c) will warn about (?g) -- japhy */
2115 I32 wastedflags = 0x00,
2118 wasted_gc = 0x02 | 0x04,
2121 char * parse_start = RExC_parse; /* MJD */
2122 char *oregcomp_parse = RExC_parse;
2125 *flagp = 0; /* Tentatively. */
2128 /* Make an OPEN node, if parenthesized. */
2130 if (*RExC_parse == '?') { /* (?...) */
2131 U16 posflags = 0, negflags = 0;
2132 U16 *flagsp = &posflags;
2134 char *seqstart = RExC_parse;
2137 paren = *RExC_parse++;
2138 ret = NULL; /* For look-ahead/behind. */
2140 case '<': /* (?<...) */
2141 RExC_seen |= REG_SEEN_LOOKBEHIND;
2142 if (*RExC_parse == '!')
2144 if (*RExC_parse != '=' && *RExC_parse != '!')
2147 case '=': /* (?=...) */
2148 case '!': /* (?!...) */
2149 RExC_seen_zerolen++;
2150 case ':': /* (?:...) */
2151 case '>': /* (?>...) */
2153 case '$': /* (?$...) */
2154 case '@': /* (?@...) */
2155 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
2157 case '#': /* (?#...) */
2158 while (*RExC_parse && *RExC_parse != ')')
2160 if (*RExC_parse != ')')
2161 FAIL("Sequence (?#... not terminated");
2162 nextchar(pRExC_state);
2165 case 'p': /* (?p...) */
2166 if (SIZE_ONLY && ckWARN2(WARN_DEPRECATED, WARN_REGEXP))
2167 vWARNdep(RExC_parse, "(?p{}) is deprecated - use (??{})");
2169 case '?': /* (??...) */
2171 if (*RExC_parse != '{')
2173 paren = *RExC_parse++;
2175 case '{': /* (?{...}) */
2177 I32 count = 1, n = 0;
2179 char *s = RExC_parse;
2181 OP_4tree *sop, *rop;
2183 RExC_seen_zerolen++;
2184 RExC_seen |= REG_SEEN_EVAL;
2185 while (count && (c = *RExC_parse)) {
2186 if (c == '\\' && RExC_parse[1])
2194 if (*RExC_parse != ')')
2197 vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
2202 if (RExC_parse - 1 - s)
2203 sv = newSVpvn(s, RExC_parse - 1 - s);
2205 sv = newSVpvn("", 0);
2208 Perl_save_re_context(aTHX);
2209 rop = sv_compile_2op(sv, &sop, "re", &av);
2210 sop->op_private |= OPpREFCOUNTED;
2211 /* re_dup will OpREFCNT_inc */
2212 OpREFCNT_set(sop, 1);
2215 n = add_data(pRExC_state, 3, "nop");
2216 RExC_rx->data->data[n] = (void*)rop;
2217 RExC_rx->data->data[n+1] = (void*)sop;
2218 RExC_rx->data->data[n+2] = (void*)av;
2221 else { /* First pass */
2222 if (PL_reginterp_cnt < ++RExC_seen_evals
2223 && PL_curcop != &PL_compiling)
2224 /* No compiled RE interpolated, has runtime
2225 components ===> unsafe. */
2226 FAIL("Eval-group not allowed at runtime, use re 'eval'");
2227 if (PL_tainting && PL_tainted)
2228 FAIL("Eval-group in insecure regular expression");
2231 nextchar(pRExC_state);
2233 ret = reg_node(pRExC_state, LOGICAL);
2236 regtail(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
2237 /* deal with the length of this later - MJD */
2240 return reganode(pRExC_state, EVAL, n);
2242 case '(': /* (?(?{...})...) and (?(?=...)...) */
2244 if (RExC_parse[0] == '?') { /* (?(?...)) */
2245 if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
2246 || RExC_parse[1] == '<'
2247 || RExC_parse[1] == '{') { /* Lookahead or eval. */
2250 ret = reg_node(pRExC_state, LOGICAL);
2253 regtail(pRExC_state, ret, reg(pRExC_state, 1, &flag));
2257 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
2259 parno = atoi(RExC_parse++);
2261 while (isDIGIT(*RExC_parse))
2263 ret = reganode(pRExC_state, GROUPP, parno);
2265 if ((c = *nextchar(pRExC_state)) != ')')
2266 vFAIL("Switch condition not recognized");
2268 regtail(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
2269 br = regbranch(pRExC_state, &flags, 1);
2271 br = reganode(pRExC_state, LONGJMP, 0);
2273 regtail(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
2274 c = *nextchar(pRExC_state);
2278 lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
2279 regbranch(pRExC_state, &flags, 1);
2280 regtail(pRExC_state, ret, lastbr);
2283 c = *nextchar(pRExC_state);
2288 vFAIL("Switch (?(condition)... contains too many branches");
2289 ender = reg_node(pRExC_state, TAIL);
2290 regtail(pRExC_state, br, ender);
2292 regtail(pRExC_state, lastbr, ender);
2293 regtail(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
2296 regtail(pRExC_state, ret, ender);
2300 vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
2304 RExC_parse--; /* for vFAIL to print correctly */
2305 vFAIL("Sequence (? incomplete");
2309 parse_flags: /* (?i) */
2310 while (*RExC_parse && strchr("iogcmsx", *RExC_parse)) {
2311 /* (?g), (?gc) and (?o) are useless here
2312 and must be globally applied -- japhy */
2314 if (*RExC_parse == 'o' || *RExC_parse == 'g') {
2315 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
2316 I32 wflagbit = *RExC_parse == 'o' ? wasted_o : wasted_g;
2317 if (! (wastedflags & wflagbit) ) {
2318 wastedflags |= wflagbit;
2321 "Useless (%s%c) - %suse /%c modifier",
2322 flagsp == &negflags ? "?-" : "?",
2324 flagsp == &negflags ? "don't " : "",
2330 else if (*RExC_parse == 'c') {
2331 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
2332 if (! (wastedflags & wasted_c) ) {
2333 wastedflags |= wasted_gc;
2336 "Useless (%sc) - %suse /gc modifier",
2337 flagsp == &negflags ? "?-" : "?",
2338 flagsp == &negflags ? "don't " : ""
2343 else { pmflag(flagsp, *RExC_parse); }
2347 if (*RExC_parse == '-') {
2349 wastedflags = 0; /* reset so (?g-c) warns twice */
2353 RExC_flags16 |= posflags;
2354 RExC_flags16 &= ~negflags;
2355 if (*RExC_parse == ':') {
2361 if (*RExC_parse != ')') {
2363 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
2365 nextchar(pRExC_state);
2373 ret = reganode(pRExC_state, OPEN, parno);
2374 Set_Node_Length(ret, 1); /* MJD */
2375 Set_Node_Offset(ret, RExC_parse); /* MJD */
2382 /* Pick up the branches, linking them together. */
2383 parse_start = RExC_parse; /* MJD */
2384 br = regbranch(pRExC_state, &flags, 1);
2385 /* branch_len = (paren != 0); */
2389 if (*RExC_parse == '|') {
2390 if (!SIZE_ONLY && RExC_extralen) {
2391 reginsert(pRExC_state, BRANCHJ, br);
2394 reginsert(pRExC_state, BRANCH, br);
2395 Set_Node_Length(br, paren != 0);
2396 Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
2400 RExC_extralen += 1; /* For BRANCHJ-BRANCH. */
2402 else if (paren == ':') {
2403 *flagp |= flags&SIMPLE;
2405 if (open) { /* Starts with OPEN. */
2406 regtail(pRExC_state, ret, br); /* OPEN -> first. */
2408 else if (paren != '?') /* Not Conditional */
2410 *flagp |= flags & (SPSTART | HASWIDTH);
2412 while (*RExC_parse == '|') {
2413 if (!SIZE_ONLY && RExC_extralen) {
2414 ender = reganode(pRExC_state, LONGJMP,0);
2415 regtail(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
2418 RExC_extralen += 2; /* Account for LONGJMP. */
2419 nextchar(pRExC_state);
2420 br = regbranch(pRExC_state, &flags, 0);
2424 regtail(pRExC_state, lastbr, br); /* BRANCH -> BRANCH. */
2428 *flagp |= flags&SPSTART;
2431 if (have_branch || paren != ':') {
2432 /* Make a closing node, and hook it on the end. */
2435 ender = reg_node(pRExC_state, TAIL);
2438 ender = reganode(pRExC_state, CLOSE, parno);
2439 Set_Node_Offset(ender,RExC_parse+1); /* MJD */
2440 Set_Node_Length(ender,1); /* MJD */
2446 *flagp &= ~HASWIDTH;
2449 ender = reg_node(pRExC_state, SUCCEED);
2452 ender = reg_node(pRExC_state, END);
2455 regtail(pRExC_state, lastbr, ender);
2458 /* Hook the tails of the branches to the closing node. */
2459 for (br = ret; br != NULL; br = regnext(br)) {
2460 regoptail(pRExC_state, br, ender);
2467 static char parens[] = "=!<,>";
2469 if (paren && (p = strchr(parens, paren))) {
2470 int node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
2471 int flag = (p - parens) > 1;
2474 node = SUSPEND, flag = 0;
2475 reginsert(pRExC_state, node,ret);
2477 regtail(pRExC_state, ret, reg_node(pRExC_state, TAIL));
2481 /* Check for proper termination. */
2483 RExC_flags16 = oregflags;
2484 if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
2485 RExC_parse = oregcomp_parse;
2486 vFAIL("Unmatched (");
2489 else if (!paren && RExC_parse < RExC_end) {
2490 if (*RExC_parse == ')') {
2492 vFAIL("Unmatched )");
2495 FAIL("Junk on end of regexp"); /* "Can't happen". */
2503 - regbranch - one alternative of an | operator
2505 * Implements the concatenation operator.
2508 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first)
2510 register regnode *ret;
2511 register regnode *chain = NULL;
2512 register regnode *latest;
2513 I32 flags = 0, c = 0;
2518 if (!SIZE_ONLY && RExC_extralen)
2519 ret = reganode(pRExC_state, BRANCHJ,0);
2521 ret = reg_node(pRExC_state, BRANCH);
2522 Set_Node_Length(ret, 1);
2526 if (!first && SIZE_ONLY)
2527 RExC_extralen += 1; /* BRANCHJ */
2529 *flagp = WORST; /* Tentatively. */
2532 nextchar(pRExC_state);
2533 while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
2535 latest = regpiece(pRExC_state, &flags);
2536 if (latest == NULL) {
2537 if (flags & TRYAGAIN)
2541 else if (ret == NULL)
2543 *flagp |= flags&HASWIDTH;
2544 if (chain == NULL) /* First piece. */
2545 *flagp |= flags&SPSTART;
2548 regtail(pRExC_state, chain, latest);
2553 if (chain == NULL) { /* Loop ran zero times. */
2554 chain = reg_node(pRExC_state, NOTHING);
2559 *flagp |= flags&SIMPLE;
2566 - regpiece - something followed by possible [*+?]
2568 * Note that the branching code sequences used for ? and the general cases
2569 * of * and + are somewhat optimized: they use the same NOTHING node as
2570 * both the endmarker for their branch list and the body of the last branch.
2571 * It might seem that this node could be dispensed with entirely, but the
2572 * endmarker role is not redundant.
2575 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp)
2577 register regnode *ret;
2579 register char *next;
2581 char *origparse = RExC_parse;
2584 I32 max = REG_INFTY;
2587 ret = regatom(pRExC_state, &flags);
2589 if (flags & TRYAGAIN)
2596 if (op == '{' && regcurly(RExC_parse)) {
2597 parse_start = RExC_parse; /* MJD */
2598 next = RExC_parse + 1;
2600 while (isDIGIT(*next) || *next == ',') {
2609 if (*next == '}') { /* got one */
2613 min = atoi(RExC_parse);
2617 maxpos = RExC_parse;
2619 if (!max && *maxpos != '0')
2620 max = REG_INFTY; /* meaning "infinity" */
2621 else if (max >= REG_INFTY)
2622 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
2624 nextchar(pRExC_state);
2627 if ((flags&SIMPLE)) {
2628 RExC_naughty += 2 + RExC_naughty / 2;
2629 reginsert(pRExC_state, CURLY, ret);
2630 Set_Node_Offset(ret, parse_start+1); /* MJD */
2631 Set_Node_Cur_Length(ret);
2634 regnode *w = reg_node(pRExC_state, WHILEM);
2637 regtail(pRExC_state, ret, w);
2638 if (!SIZE_ONLY && RExC_extralen) {
2639 reginsert(pRExC_state, LONGJMP,ret);
2640 reginsert(pRExC_state, NOTHING,ret);
2641 NEXT_OFF(ret) = 3; /* Go over LONGJMP. */
2643 reginsert(pRExC_state, CURLYX,ret);
2645 Set_Node_Offset(ret, parse_start+1);
2646 Set_Node_Length(ret,
2647 op == '{' ? (RExC_parse - parse_start) : 1);
2649 if (!SIZE_ONLY && RExC_extralen)
2650 NEXT_OFF(ret) = 3; /* Go over NOTHING to LONGJMP. */
2651 regtail(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
2653 RExC_whilem_seen++, RExC_extralen += 3;
2654 RExC_naughty += 4 + RExC_naughty; /* compound interest */
2662 if (max && max < min)
2663 vFAIL("Can't do {n,m} with n > m");
2678 #if 0 /* Now runtime fix should be reliable. */
2680 /* if this is reinstated, don't forget to put this back into perldiag:
2682 =item Regexp *+ operand could be empty at {#} in regex m/%s/
2684 (F) The part of the regexp subject to either the * or + quantifier
2685 could match an empty string. The {#} shows in the regular
2686 expression about where the problem was discovered.
2690 if (!(flags&HASWIDTH) && op != '?')
2691 vFAIL("Regexp *+ operand could be empty");
2694 parse_start = RExC_parse;
2695 nextchar(pRExC_state);
2697 *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
2699 if (op == '*' && (flags&SIMPLE)) {
2700 reginsert(pRExC_state, STAR, ret);
2704 else if (op == '*') {
2708 else if (op == '+' && (flags&SIMPLE)) {
2709 reginsert(pRExC_state, PLUS, ret);
2713 else if (op == '+') {
2717 else if (op == '?') {
2722 if (ckWARN(WARN_REGEXP) && !SIZE_ONLY && !(flags&HASWIDTH) && max > REG_INFTY/3) {
2724 "%.*s matches null string many times",
2725 RExC_parse - origparse,
2729 if (*RExC_parse == '?') {
2730 nextchar(pRExC_state);
2731 reginsert(pRExC_state, MINMOD, ret);
2732 regtail(pRExC_state, ret, ret + NODE_STEP_REGNODE);
2734 if (ISMULT2(RExC_parse)) {
2736 vFAIL("Nested quantifiers");
2743 - regatom - the lowest level
2745 * Optimization: gobbles an entire sequence of ordinary characters so that
2746 * it can turn them into a single node, which is smaller to store and
2747 * faster to run. Backslashed characters are exceptions, each becoming a
2748 * separate node; the code is simpler that way and it's not worth fixing.
2750 * [Yes, it is worth fixing, some scripts can run twice the speed.] */
2752 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp)
2754 register regnode *ret = 0;
2756 char *parse_start = 0;
2758 *flagp = WORST; /* Tentatively. */
2761 switch (*RExC_parse) {
2763 RExC_seen_zerolen++;
2764 nextchar(pRExC_state);
2765 if (RExC_flags16 & PMf_MULTILINE)
2766 ret = reg_node(pRExC_state, MBOL);
2767 else if (RExC_flags16 & PMf_SINGLELINE)
2768 ret = reg_node(pRExC_state, SBOL);
2770 ret = reg_node(pRExC_state, BOL);
2771 Set_Node_Length(ret, 1); /* MJD */
2774 nextchar(pRExC_state);
2776 RExC_seen_zerolen++;
2777 if (RExC_flags16 & PMf_MULTILINE)
2778 ret = reg_node(pRExC_state, MEOL);
2779 else if (RExC_flags16 & PMf_SINGLELINE)
2780 ret = reg_node(pRExC_state, SEOL);
2782 ret = reg_node(pRExC_state, EOL);
2783 Set_Node_Length(ret, 1); /* MJD */
2786 nextchar(pRExC_state);
2787 if (RExC_flags16 & PMf_SINGLELINE)
2788 ret = reg_node(pRExC_state, SANY);
2790 ret = reg_node(pRExC_state, REG_ANY);
2791 *flagp |= HASWIDTH|SIMPLE;
2793 Set_Node_Length(ret, 1); /* MJD */
2797 char *oregcomp_parse = ++RExC_parse;
2798 ret = regclass(pRExC_state);
2799 if (*RExC_parse != ']') {
2800 RExC_parse = oregcomp_parse;
2801 vFAIL("Unmatched [");
2803 nextchar(pRExC_state);
2804 *flagp |= HASWIDTH|SIMPLE;
2805 Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
2809 nextchar(pRExC_state);
2810 ret = reg(pRExC_state, 1, &flags);
2812 if (flags & TRYAGAIN) {
2813 if (RExC_parse == RExC_end) {
2814 /* Make parent create an empty node if needed. */
2822 *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE);
2826 if (flags & TRYAGAIN) {
2830 vFAIL("Internal urp");
2831 /* Supposed to be caught earlier. */
2834 if (!regcurly(RExC_parse)) {
2843 vFAIL("Quantifier follows nothing");
2846 switch (*++RExC_parse) {
2848 RExC_seen_zerolen++;
2849 ret = reg_node(pRExC_state, SBOL);
2851 nextchar(pRExC_state);
2852 Set_Node_Length(ret, 2); /* MJD */
2855 ret = reg_node(pRExC_state, GPOS);
2856 RExC_seen |= REG_SEEN_GPOS;
2858 nextchar(pRExC_state);
2859 Set_Node_Length(ret, 2); /* MJD */
2862 ret = reg_node(pRExC_state, SEOL);
2864 RExC_seen_zerolen++; /* Do not optimize RE away */
2865 nextchar(pRExC_state);
2868 ret = reg_node(pRExC_state, EOS);
2870 RExC_seen_zerolen++; /* Do not optimize RE away */
2871 nextchar(pRExC_state);
2872 Set_Node_Length(ret, 2); /* MJD */
2875 ret = reg_node(pRExC_state, CANY);
2876 RExC_seen |= REG_SEEN_CANY;
2877 *flagp |= HASWIDTH|SIMPLE;
2878 nextchar(pRExC_state);
2879 Set_Node_Length(ret, 2); /* MJD */
2882 ret = reg_node(pRExC_state, CLUMP);
2884 nextchar(pRExC_state);
2885 Set_Node_Length(ret, 2); /* MJD */
2888 ret = reg_node(pRExC_state, LOC ? ALNUML : ALNUM);
2889 *flagp |= HASWIDTH|SIMPLE;
2890 nextchar(pRExC_state);
2891 Set_Node_Length(ret, 2); /* MJD */
2894 ret = reg_node(pRExC_state, LOC ? NALNUML : NALNUM);
2895 *flagp |= HASWIDTH|SIMPLE;
2896 nextchar(pRExC_state);
2897 Set_Node_Length(ret, 2); /* MJD */
2900 RExC_seen_zerolen++;
2901 RExC_seen |= REG_SEEN_LOOKBEHIND;
2902 ret = reg_node(pRExC_state, LOC ? BOUNDL : BOUND);
2904 nextchar(pRExC_state);
2905 Set_Node_Length(ret, 2); /* MJD */
2908 RExC_seen_zerolen++;
2909 RExC_seen |= REG_SEEN_LOOKBEHIND;
2910 ret = reg_node(pRExC_state, LOC ? NBOUNDL : NBOUND);
2912 nextchar(pRExC_state);
2913 Set_Node_Length(ret, 2); /* MJD */
2916 ret = reg_node(pRExC_state, LOC ? SPACEL : SPACE);
2917 *flagp |= HASWIDTH|SIMPLE;
2918 nextchar(pRExC_state);
2919 Set_Node_Length(ret, 2); /* MJD */
2922 ret = reg_node(pRExC_state, LOC ? NSPACEL : NSPACE);
2923 *flagp |= HASWIDTH|SIMPLE;
2924 nextchar(pRExC_state);
2925 Set_Node_Length(ret, 2); /* MJD */
2928 ret = reg_node(pRExC_state, DIGIT);
2929 *flagp |= HASWIDTH|SIMPLE;
2930 nextchar(pRExC_state);
2931 Set_Node_Length(ret, 2); /* MJD */
2934 ret = reg_node(pRExC_state, NDIGIT);
2935 *flagp |= HASWIDTH|SIMPLE;
2936 nextchar(pRExC_state);
2937 Set_Node_Length(ret, 2); /* MJD */
2942 char* oldregxend = RExC_end;
2943 char* parse_start = RExC_parse;
2945 if (RExC_parse[1] == '{') {
2946 /* a lovely hack--pretend we saw [\pX] instead */
2947 RExC_end = strchr(RExC_parse, '}');
2949 U8 c = (U8)*RExC_parse;
2951 RExC_end = oldregxend;
2952 vFAIL2("Missing right brace on \\%c{}", c);
2957 RExC_end = RExC_parse + 2;
2960 ret = regclass(pRExC_state);
2962 RExC_end = oldregxend;
2964 Set_Node_Cur_Length(ret); /* MJD */
2965 nextchar(pRExC_state);
2966 *flagp |= HASWIDTH|SIMPLE;
2979 case '1': case '2': case '3': case '4':
2980 case '5': case '6': case '7': case '8': case '9':
2982 I32 num = atoi(RExC_parse);
2984 if (num > 9 && num >= RExC_npar)
2987 char * parse_start = RExC_parse - 1; /* MJD */
2988 while (isDIGIT(*RExC_parse))
2991 if (!SIZE_ONLY && num > RExC_rx->nparens)
2992 vFAIL("Reference to nonexistent group");
2994 ret = reganode(pRExC_state, FOLD
2995 ? (LOC ? REFFL : REFF)
2999 /* override incorrect value set in reganode MJD */
3000 Set_Node_Offset(ret, parse_start+1);
3001 Set_Node_Cur_Length(ret); /* MJD */
3003 nextchar(pRExC_state);
3008 if (RExC_parse >= RExC_end)
3009 FAIL("Trailing \\");
3012 /* Do not generate `unrecognized' warnings here, we fall
3013 back into the quick-grab loop below */
3019 if (RExC_flags16 & PMf_EXTENDED) {
3020 while (RExC_parse < RExC_end && *RExC_parse != '\n') RExC_parse++;
3021 if (RExC_parse < RExC_end)
3027 register STRLEN len;
3033 U8 tmpbuf[UTF8_MAXLEN_FOLD+1], *foldbuf;
3035 parse_start = RExC_parse - 1;
3040 ret = reg_node(pRExC_state, FOLD
3041 ? (LOC ? EXACTFL : EXACTF)
3044 for (len = 0, p = RExC_parse - 1;
3045 len < 127 && p < RExC_end;
3050 if (RExC_flags16 & PMf_EXTENDED)
3051 p = regwhite(p, RExC_end);
3098 ender = ASCII_TO_NATIVE('\033');
3102 ender = ASCII_TO_NATIVE('\007');
3107 char* e = strchr(p, '}');
3111 vFAIL("Missing right brace on \\x{}");
3114 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3115 | PERL_SCAN_DISALLOW_PREFIX;
3117 ender = grok_hex(p + 1, &numlen, &flags, NULL);
3120 /* numlen is generous */
3121 if (numlen + len >= 127) {
3129 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
3131 ender = grok_hex(p, &numlen, &flags, NULL);
3137 ender = UCHARAT(p++);
3138 ender = toCTRL(ender);
3140 case '0': case '1': case '2': case '3':case '4':
3141 case '5': case '6': case '7': case '8':case '9':
3143 (isDIGIT(p[1]) && atoi(p) >= RExC_npar) ) {
3146 ender = grok_oct(p, &numlen, &flags, NULL);
3156 FAIL("Trailing \\");
3159 if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && isALPHA(*p))
3160 vWARN2(p + 1, "Unrecognized escape \\%c passed through", UCHARAT(p));
3161 goto normal_default;
3166 if (UTF8_IS_START(*p) && UTF) {
3167 ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
3175 if (RExC_flags16 & PMf_EXTENDED)
3176 p = regwhite(p, RExC_end);
3178 /* Prime the casefolded buffer. */
3179 ender = toFOLD_uni(ender, tmpbuf, &foldlen);
3181 if (ISMULT2(p)) { /* Back off on ?+*. */
3188 /* Emit all the Unicode characters. */
3189 for (foldbuf = tmpbuf;
3191 foldlen -= numlen) {
3192 ender = utf8_to_uvchr(foldbuf, &numlen);
3194 reguni(pRExC_state, ender, s, &unilen);
3197 /* In EBCDIC the numlen
3198 * and unilen can differ. */
3200 if (numlen >= foldlen)
3204 break; /* "Can't happen." */
3208 reguni(pRExC_state, ender, s, &unilen);
3225 /* Emit all the Unicode characters. */
3226 for (foldbuf = tmpbuf;
3228 foldlen -= numlen) {
3229 ender = utf8_to_uvchr(foldbuf, &numlen);
3231 reguni(pRExC_state, ender, s, &unilen);
3234 /* In EBCDIC the numlen
3235 * and unilen can differ. */
3237 if (numlen >= foldlen)
3245 reguni(pRExC_state, ender, s, &unilen);
3258 Set_Node_Cur_Length(ret); /* MJD */
3259 nextchar(pRExC_state);
3261 /* len is STRLEN which is unsigned, need to copy to signed */
3264 vFAIL("Internal disaster");
3273 RExC_size += STR_SZ(len);
3275 RExC_emit += STR_SZ(len);
3280 /* If the encoding pragma is in effect recode the text of
3281 * any EXACT-kind nodes. */
3282 if (PL_encoding && PL_regkind[(U8)OP(ret)] == EXACT) {
3283 STRLEN oldlen = STR_LEN(ret);
3284 SV *sv = sv_2mortal(newSVpvn(STRING(ret), oldlen));
3288 if (sv_utf8_downgrade(sv, TRUE)) {
3289 char *s = Perl_sv_recode_to_utf8(aTHX_ sv, PL_encoding);
3290 STRLEN newlen = SvCUR(sv);
3293 DEBUG_r(PerlIO_printf(Perl_debug_log, "recode %*s to %*s\n",
3294 (int)oldlen, STRING(ret),
3296 Copy(s, STRING(ret), newlen, char);
3297 STR_LEN(ret) += newlen - oldlen;
3298 RExC_emit += STR_SZ(newlen) - STR_SZ(oldlen);
3300 RExC_size += STR_SZ(newlen) - STR_SZ(oldlen);
3308 S_regwhite(pTHX_ char *p, char *e)
3313 else if (*p == '#') {
3316 } while (p < e && *p != '\n');
3324 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
3325 Character classes ([:foo:]) can also be negated ([:^foo:]).
3326 Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
3327 Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
3328 but trigger failures because they are currently unimplemented. */
3330 #define POSIXCC_DONE(c) ((c) == ':')
3331 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
3332 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
3335 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
3338 I32 namedclass = OOB_NAMEDCLASS;
3340 if (value == '[' && RExC_parse + 1 < RExC_end &&
3341 /* I smell either [: or [= or [. -- POSIX has been here, right? */
3342 POSIXCC(UCHARAT(RExC_parse))) {
3343 char c = UCHARAT(RExC_parse);
3344 char* s = RExC_parse++;
3346 while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
3348 if (RExC_parse == RExC_end)
3349 /* Grandfather lone [:, [=, [. */
3352 char* t = RExC_parse++; /* skip over the c */
3354 if (UCHARAT(RExC_parse) == ']') {
3355 RExC_parse++; /* skip over the ending ] */
3358 I32 complement = *posixcc == '^' ? *posixcc++ : 0;
3359 I32 skip = 5; /* the most common skip */
3363 if (strnEQ(posixcc, "alnum", 5))
3365 complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
3366 else if (strnEQ(posixcc, "alpha", 5))
3368 complement ? ANYOF_NALPHA : ANYOF_ALPHA;
3369 else if (strnEQ(posixcc, "ascii", 5))
3371 complement ? ANYOF_NASCII : ANYOF_ASCII;
3374 if (strnEQ(posixcc, "blank", 5))
3376 complement ? ANYOF_NBLANK : ANYOF_BLANK;
3379 if (strnEQ(posixcc, "cntrl", 5))
3381 complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
3384 if (strnEQ(posixcc, "digit", 5))
3386 complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
3389 if (strnEQ(posixcc, "graph", 5))
3391 complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
3394 if (strnEQ(posixcc, "lower", 5))
3396 complement ? ANYOF_NLOWER : ANYOF_LOWER;
3399 if (strnEQ(posixcc, "print", 5))
3401 complement ? ANYOF_NPRINT : ANYOF_PRINT;
3402 else if (strnEQ(posixcc, "punct", 5))
3404 complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
3407 if (strnEQ(posixcc, "space", 5))
3409 complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
3412 if (strnEQ(posixcc, "upper", 5))
3414 complement ? ANYOF_NUPPER : ANYOF_UPPER;
3416 case 'w': /* this is not POSIX, this is the Perl \w */
3417 if (strnEQ(posixcc, "word", 4)) {
3419 complement ? ANYOF_NALNUM : ANYOF_ALNUM;
3424 if (strnEQ(posixcc, "xdigit", 6)) {
3426 complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
3431 if (namedclass == OOB_NAMEDCLASS ||
3432 posixcc[skip] != ':' ||
3433 posixcc[skip+1] != ']')
3435 Simple_vFAIL3("POSIX class [:%.*s:] unknown",
3438 } else if (!SIZE_ONLY) {
3439 /* [[=foo=]] and [[.foo.]] are still future. */
3441 /* adjust RExC_parse so the warning shows after
3443 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
3445 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
3448 /* Maternal grandfather:
3449 * "[:" ending in ":" but not in ":]" */
3459 S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
3461 if (!SIZE_ONLY && POSIXCC(UCHARAT(RExC_parse))) {
3462 char *s = RExC_parse;
3465 while(*s && isALNUM(*s))
3467 if (*s && c == *s && s[1] == ']') {
3468 vWARN3(s+2, "POSIX syntax [%c %c] belongs inside character classes", c, c);
3470 /* [[=foo=]] and [[.foo.]] are still future. */
3471 if (POSIXCC_NOTYET(c)) {
3472 /* adjust RExC_parse so the error shows after
3474 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
3476 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
3483 S_regclass(pTHX_ RExC_state_t *pRExC_state)
3486 register UV nextvalue;
3487 register IV prevvalue = OOB_UNICODE;
3488 register IV range = 0;
3489 register regnode *ret;
3492 char *rangebegin = 0;
3493 bool need_class = 0;
3494 SV *listsv = Nullsv;
3497 bool optimize_invert = TRUE;
3498 AV* unicode_alternate = 0;
3500 ret = reganode(pRExC_state, ANYOF, 0);
3503 ANYOF_FLAGS(ret) = 0;
3505 if (UCHARAT(RExC_parse) == '^') { /* Complement of range. */
3509 ANYOF_FLAGS(ret) |= ANYOF_INVERT;
3513 RExC_size += ANYOF_SKIP;
3515 RExC_emit += ANYOF_SKIP;
3517 ANYOF_FLAGS(ret) |= ANYOF_FOLD;
3519 ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
3520 ANYOF_BITMAP_ZERO(ret);
3521 listsv = newSVpvn("# comment\n", 10);
3524 nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
3526 if (!SIZE_ONLY && POSIXCC(nextvalue))
3527 checkposixcc(pRExC_state);
3529 /* allow 1st char to be ] (allowing it to be - is dealt with later) */
3530 if (UCHARAT(RExC_parse) == ']')
3533 while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
3537 namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
3540 rangebegin = RExC_parse;
3542 value = utf8n_to_uvchr((U8*)RExC_parse,
3543 RExC_end - RExC_parse,
3545 RExC_parse += numlen;
3548 value = UCHARAT(RExC_parse++);
3549 nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
3550 if (value == '[' && POSIXCC(nextvalue))
3551 namedclass = regpposixcc(pRExC_state, value);
3552 else if (value == '\\') {
3554 value = utf8n_to_uvchr((U8*)RExC_parse,
3555 RExC_end - RExC_parse,
3557 RExC_parse += numlen;
3560 value = UCHARAT(RExC_parse++);
3561 /* Some compilers cannot handle switching on 64-bit integer
3562 * values, therefore value cannot be an UV. Yes, this will
3563 * be a problem later if we want switch on Unicode.
3564 * A similar issue a little bit later when switching on
3565 * namedclass. --jhi */
3566 switch ((I32)value) {
3567 case 'w': namedclass = ANYOF_ALNUM; break;
3568 case 'W': namedclass = ANYOF_NALNUM; break;
3569 case 's': namedclass = ANYOF_SPACE; break;
3570 case 'S': namedclass = ANYOF_NSPACE; break;
3571 case 'd': namedclass = ANYOF_DIGIT; break;
3572 case 'D': namedclass = ANYOF_NDIGIT; break;
3575 if (*RExC_parse == '{') {
3577 e = strchr(RExC_parse++, '}');
3579 vFAIL2("Missing right brace on \\%c{}", c);
3580 while (isSPACE(UCHARAT(RExC_parse)))
3582 if (e == RExC_parse)
3583 vFAIL2("Empty \\%c{}", c);
3585 while (isSPACE(UCHARAT(RExC_parse + n - 1)))
3593 if (UCHARAT(RExC_parse) == '^') {
3596 value = value == 'p' ? 'P' : 'p'; /* toggle */
3597 while (isSPACE(UCHARAT(RExC_parse))) {
3603 Perl_sv_catpvf(aTHX_ listsv,
3604 "+utf8::%.*s\n", (int)n, RExC_parse);
3606 Perl_sv_catpvf(aTHX_ listsv,
3607 "!utf8::%.*s\n", (int)n, RExC_parse);
3610 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
3612 case 'n': value = '\n'; break;
3613 case 'r': value = '\r'; break;
3614 case 't': value = '\t'; break;
3615 case 'f': value = '\f'; break;
3616 case 'b': value = '\b'; break;
3617 case 'e': value = ASCII_TO_NATIVE('\033');break;
3618 case 'a': value = ASCII_TO_NATIVE('\007');break;
3620 if (*RExC_parse == '{') {
3621 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3622 | PERL_SCAN_DISALLOW_PREFIX;
3623 e = strchr(RExC_parse++, '}');
3625 vFAIL("Missing right brace on \\x{}");
3627 numlen = e - RExC_parse;
3628 value = grok_hex(RExC_parse, &numlen, &flags, NULL);
3632 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
3634 value = grok_hex(RExC_parse, &numlen, &flags, NULL);
3635 RExC_parse += numlen;
3639 value = UCHARAT(RExC_parse++);
3640 value = toCTRL(value);
3642 case '0': case '1': case '2': case '3': case '4':
3643 case '5': case '6': case '7': case '8': case '9':
3647 value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
3648 RExC_parse += numlen;
3652 if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && isALPHA(value))
3654 "Unrecognized escape \\%c in character class passed through",
3658 } /* end of \blah */
3660 if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
3662 if (!SIZE_ONLY && !need_class)
3663 ANYOF_CLASS_ZERO(ret);
3667 /* a bad range like a-\d, a-[:digit:] ? */
3670 if (ckWARN(WARN_REGEXP))
3672 "False [] range \"%*.*s\"",
3673 RExC_parse - rangebegin,
3674 RExC_parse - rangebegin,
3676 if (prevvalue < 256) {
3677 ANYOF_BITMAP_SET(ret, prevvalue);
3678 ANYOF_BITMAP_SET(ret, '-');
3681 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
3682 Perl_sv_catpvf(aTHX_ listsv,
3683 "%04"UVxf"\n%04"UVxf"\n", (UV)prevvalue, (UV) '-');
3687 range = 0; /* this was not a true range */
3691 if (namedclass > OOB_NAMEDCLASS)
3692 optimize_invert = FALSE;
3693 /* Possible truncation here but in some 64-bit environments
3694 * the compiler gets heartburn about switch on 64-bit values.
3695 * A similar issue a little earlier when switching on value.
3697 switch ((I32)namedclass) {
3700 ANYOF_CLASS_SET(ret, ANYOF_ALNUM);
3702 for (value = 0; value < 256; value++)
3704 ANYOF_BITMAP_SET(ret, value);
3706 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsWord\n");
3710 ANYOF_CLASS_SET(ret, ANYOF_NALNUM);
3712 for (value = 0; value < 256; value++)
3713 if (!isALNUM(value))
3714 ANYOF_BITMAP_SET(ret, value);
3716 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsWord\n");
3720 ANYOF_CLASS_SET(ret, ANYOF_ALNUMC);
3722 for (value = 0; value < 256; value++)
3723 if (isALNUMC(value))
3724 ANYOF_BITMAP_SET(ret, value);
3726 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsAlnum\n");
3730 ANYOF_CLASS_SET(ret, ANYOF_NALNUMC);
3732 for (value = 0; value < 256; value++)
3733 if (!isALNUMC(value))
3734 ANYOF_BITMAP_SET(ret, value);
3736 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsAlnum\n");
3740 ANYOF_CLASS_SET(ret, ANYOF_ALPHA);
3742 for (value = 0; value < 256; value++)
3744 ANYOF_BITMAP_SET(ret, value);
3746 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsAlpha\n");
3750 ANYOF_CLASS_SET(ret, ANYOF_NALPHA);
3752 for (value = 0; value < 256; value++)
3753 if (!isALPHA(value))
3754 ANYOF_BITMAP_SET(ret, value);
3756 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsAlpha\n");
3760 ANYOF_CLASS_SET(ret, ANYOF_ASCII);
3763 for (value = 0; value < 128; value++)
3764 ANYOF_BITMAP_SET(ret, value);
3766 for (value = 0; value < 256; value++) {
3768 ANYOF_BITMAP_SET(ret, value);
3772 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsASCII\n");
3776 ANYOF_CLASS_SET(ret, ANYOF_NASCII);
3779 for (value = 128; value < 256; value++)
3780 ANYOF_BITMAP_SET(ret, value);
3782 for (value = 0; value < 256; value++) {
3783 if (!isASCII(value))
3784 ANYOF_BITMAP_SET(ret, value);
3788 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsASCII\n");
3792 ANYOF_CLASS_SET(ret, ANYOF_BLANK);
3794 for (value = 0; value < 256; value++)
3796 ANYOF_BITMAP_SET(ret, value);
3798 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsBlank\n");
3802 ANYOF_CLASS_SET(ret, ANYOF_NBLANK);
3804 for (value = 0; value < 256; value++)
3805 if (!isBLANK(value))
3806 ANYOF_BITMAP_SET(ret, value);
3808 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsBlank\n");
3812 ANYOF_CLASS_SET(ret, ANYOF_CNTRL);
3814 for (value = 0; value < 256; value++)
3816 ANYOF_BITMAP_SET(ret, value);
3818 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsCntrl\n");
3822 ANYOF_CLASS_SET(ret, ANYOF_NCNTRL);
3824 for (value = 0; value < 256; value++)
3825 if (!isCNTRL(value))
3826 ANYOF_BITMAP_SET(ret, value);
3828 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsCntrl\n");
3832 ANYOF_CLASS_SET(ret, ANYOF_DIGIT);
3834 /* consecutive digits assumed */
3835 for (value = '0'; value <= '9'; value++)
3836 ANYOF_BITMAP_SET(ret, value);
3838 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsDigit\n");
3842 ANYOF_CLASS_SET(ret, ANYOF_NDIGIT);
3844 /* consecutive digits assumed */
3845 for (value = 0; value < '0'; value++)
3846 ANYOF_BITMAP_SET(ret, value);
3847 for (value = '9' + 1; value < 256; value++)
3848 ANYOF_BITMAP_SET(ret, value);
3850 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsDigit\n");
3854 ANYOF_CLASS_SET(ret, ANYOF_GRAPH);
3856 for (value = 0; value < 256; value++)
3858 ANYOF_BITMAP_SET(ret, value);
3860 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsGraph\n");
3864 ANYOF_CLASS_SET(ret, ANYOF_NGRAPH);
3866 for (value = 0; value < 256; value++)
3867 if (!isGRAPH(value))
3868 ANYOF_BITMAP_SET(ret, value);
3870 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsGraph\n");
3874 ANYOF_CLASS_SET(ret, ANYOF_LOWER);
3876 for (value = 0; value < 256; value++)
3878 ANYOF_BITMAP_SET(ret, value);
3880 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsLower\n");
3884 ANYOF_CLASS_SET(ret, ANYOF_NLOWER);
3886 for (value = 0; value < 256; value++)
3887 if (!isLOWER(value))
3888 ANYOF_BITMAP_SET(ret, value);
3890 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsLower\n");
3894 ANYOF_CLASS_SET(ret, ANYOF_PRINT);
3896 for (value = 0; value < 256; value++)
3898 ANYOF_BITMAP_SET(ret, value);
3900 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsPrint\n");
3904 ANYOF_CLASS_SET(ret, ANYOF_NPRINT);
3906 for (value = 0; value < 256; value++)
3907 if (!isPRINT(value))
3908 ANYOF_BITMAP_SET(ret, value);
3910 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsPrint\n");
3914 ANYOF_CLASS_SET(ret, ANYOF_PSXSPC);
3916 for (value = 0; value < 256; value++)
3917 if (isPSXSPC(value))
3918 ANYOF_BITMAP_SET(ret, value);
3920 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsSpace\n");
3924 ANYOF_CLASS_SET(ret, ANYOF_NPSXSPC);
3926 for (value = 0; value < 256; value++)
3927 if (!isPSXSPC(value))
3928 ANYOF_BITMAP_SET(ret, value);
3930 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsSpace\n");
3934 ANYOF_CLASS_SET(ret, ANYOF_PUNCT);
3936 for (value = 0; value < 256; value++)
3938 ANYOF_BITMAP_SET(ret, value);
3940 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsPunct\n");
3944 ANYOF_CLASS_SET(ret, ANYOF_NPUNCT);
3946 for (value = 0; value < 256; value++)
3947 if (!isPUNCT(value))
3948 ANYOF_BITMAP_SET(ret, value);
3950 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsPunct\n");
3954 ANYOF_CLASS_SET(ret, ANYOF_SPACE);
3956 for (value = 0; value < 256; value++)
3958 ANYOF_BITMAP_SET(ret, value);
3960 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsSpacePerl\n");
3964 ANYOF_CLASS_SET(ret, ANYOF_NSPACE);
3966 for (value = 0; value < 256; value++)
3967 if (!isSPACE(value))
3968 ANYOF_BITMAP_SET(ret, value);
3970 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsSpacePerl\n");
3974 ANYOF_CLASS_SET(ret, ANYOF_UPPER);
3976 for (value = 0; value < 256; value++)
3978 ANYOF_BITMAP_SET(ret, value);
3980 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsUpper\n");
3984 ANYOF_CLASS_SET(ret, ANYOF_NUPPER);
3986 for (value = 0; value < 256; value++)
3987 if (!isUPPER(value))
3988 ANYOF_BITMAP_SET(ret, value);
3990 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsUpper\n");
3994 ANYOF_CLASS_SET(ret, ANYOF_XDIGIT);
3996 for (value = 0; value < 256; value++)
3997 if (isXDIGIT(value))
3998 ANYOF_BITMAP_SET(ret, value);
4000 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsXDigit\n");
4004 ANYOF_CLASS_SET(ret, ANYOF_NXDIGIT);
4006 for (value = 0; value < 256; value++)
4007 if (!isXDIGIT(value))
4008 ANYOF_BITMAP_SET(ret, value);
4010 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsXDigit\n");
4013 vFAIL("Invalid [::] class");
4017 ANYOF_FLAGS(ret) |= ANYOF_CLASS;
4020 } /* end of namedclass \blah */
4023 if (prevvalue > value) /* b-a */ {
4024 Simple_vFAIL4("Invalid [] range \"%*.*s\"",
4025 RExC_parse - rangebegin,
4026 RExC_parse - rangebegin,
4028 range = 0; /* not a valid range */
4032 prevvalue = value; /* save the beginning of the range */
4033 if (*RExC_parse == '-' && RExC_parse+1 < RExC_end &&
4034 RExC_parse[1] != ']') {
4037 /* a bad range like \w-, [:word:]- ? */
4038 if (namedclass > OOB_NAMEDCLASS) {
4039 if (ckWARN(WARN_REGEXP))
4041 "False [] range \"%*.*s\"",
4042 RExC_parse - rangebegin,
4043 RExC_parse - rangebegin,
4046 ANYOF_BITMAP_SET(ret, '-');
4048 range = 1; /* yeah, it's a range! */
4049 continue; /* but do it the next time */
4053 /* now is the next time */
4057 if (prevvalue < 256) {
4058 IV ceilvalue = value < 256 ? value : 255;
4061 if ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
4062 (isUPPER(prevvalue) && isUPPER(ceilvalue)))
4064 if (isLOWER(prevvalue)) {
4065 for (i = prevvalue; i <= ceilvalue; i++)
4067 ANYOF_BITMAP_SET(ret, i);
4069 for (i = prevvalue; i <= ceilvalue; i++)
4071 ANYOF_BITMAP_SET(ret, i);
4076 for (i = prevvalue; i <= ceilvalue; i++)
4077 ANYOF_BITMAP_SET(ret, i);
4079 if (value > 255 || UTF) {
4080 UV prevnatvalue = NATIVE_TO_UNI(prevvalue);
4081 UV natvalue = NATIVE_TO_UNI(value);
4083 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
4084 if (prevnatvalue < natvalue) { /* what about > ? */
4085 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
4086 prevnatvalue, natvalue);
4088 else if (prevnatvalue == natvalue) {
4089 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", natvalue);
4091 U8 foldbuf[UTF8_MAXLEN_FOLD+1];
4093 UV f = to_uni_fold(natvalue, foldbuf, &foldlen);
4095 /* If folding and foldable and a single
4096 * character, insert also the folded version
4097 * to the charclass. */
4099 if (foldlen == UNISKIP(f))
4100 Perl_sv_catpvf(aTHX_ listsv,
4103 /* Any multicharacter foldings
4104 * require the following transform:
4105 * [ABCDEF] -> (?:[ABCabcDEFd]|pq|rst)
4106 * where E folds into "pq" and F folds
4107 * into "rst", all other characters
4108 * fold to single characters. We save
4109 * away these multicharacter foldings,
4110 * to be later saved as part of the
4111 * additional "s" data. */
4114 if (!unicode_alternate)
4115 unicode_alternate = newAV();
4116 sv = newSVpvn((char*)foldbuf, foldlen);
4118 av_push(unicode_alternate, sv);
4122 /* If folding and the value is one of the Greek
4123 * sigmas insert a few more sigmas to make the
4124 * folding rules of the sigmas to work right.
4125 * Note that not all the possible combinations
4126 * are handled here: some of them are handled
4127 * by the standard folding rules, and some of
4128 * them (literal or EXACTF cases) are handled
4129 * during runtime in regexec.c:S_find_byclass(). */
4130 if (value == UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA) {
4131 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
4132 (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA);
4133 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
4134 (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
4136 else if (value == UNICODE_GREEK_CAPITAL_LETTER_SIGMA)
4137 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
4138 (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
4144 range = 0; /* this range (if it was one) is done now */
4148 ANYOF_FLAGS(ret) |= ANYOF_LARGE;
4150 RExC_size += ANYOF_CLASS_ADD_SKIP;
4152 RExC_emit += ANYOF_CLASS_ADD_SKIP;
4155 /* optimize case-insensitive simple patterns (e.g. /[a-z]/i) */
4157 /* If the only flag is folding (plus possibly inversion). */
4158 ((ANYOF_FLAGS(ret) & (ANYOF_FLAGS_ALL ^ ANYOF_INVERT)) == ANYOF_FOLD)
4160 for (value = 0; value < 256; ++value) {
4161 if (ANYOF_BITMAP_TEST(ret, value)) {
4162 IV fold = PL_fold[value];
4165 ANYOF_BITMAP_SET(ret, fold);
4168 ANYOF_FLAGS(ret) &= ~ANYOF_FOLD;
4171 /* optimize inverted simple patterns (e.g. [^a-z]) */
4172 if (!SIZE_ONLY && optimize_invert &&
4173 /* If the only flag is inversion. */
4174 (ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT) {
4175 for (value = 0; value < ANYOF_BITMAP_SIZE; ++value)
4176 ANYOF_BITMAP(ret)[value] ^= ANYOF_FLAGS_ALL;
4177 ANYOF_FLAGS(ret) = ANYOF_UNICODE_ALL;
4184 /* The 0th element stores the character class description
4185 * in its textual form: used later (regexec.c:Perl_regclass_swatch())
4186 * to initialize the appropriate swash (which gets stored in
4187 * the 1st element), and also useful for dumping the regnode.
4188 * The 2nd element stores the multicharacter foldings,
4189 * used later (regexec.c:s_reginclasslen()). */
4190 av_store(av, 0, listsv);
4191 av_store(av, 1, NULL);
4192 av_store(av, 2, (SV*)unicode_alternate);
4193 rv = newRV_noinc((SV*)av);
4194 n = add_data(pRExC_state, 1, "s");
4195 RExC_rx->data->data[n] = (void*)rv;
4203 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
4205 char* retval = RExC_parse++;
4208 if (*RExC_parse == '(' && RExC_parse[1] == '?' &&
4209 RExC_parse[2] == '#') {
4210 while (*RExC_parse && *RExC_parse != ')')
4215 if (RExC_flags16 & PMf_EXTENDED) {
4216 if (isSPACE(*RExC_parse)) {
4220 else if (*RExC_parse == '#') {
4221 while (*RExC_parse && *RExC_parse != '\n')
4232 - reg_node - emit a node
4234 STATIC regnode * /* Location. */
4235 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
4237 register regnode *ret;
4238 register regnode *ptr;
4242 SIZE_ALIGN(RExC_size);
4247 NODE_ALIGN_FILL(ret);
4249 FILL_ADVANCE_NODE(ptr, op);
4250 if (RExC_offsets) { /* MJD */
4251 MJD_OFFSET_DEBUG((stderr, "%s:%u: (op %s) %s %u <- %u (len %u) (max %u).\n",
4252 "reg_node", __LINE__,
4254 RExC_emit - RExC_emit_start > RExC_offsets[0]
4255 ? "Overwriting end of array!\n" : "OK",
4256 RExC_emit - RExC_emit_start,
4257 RExC_parse - RExC_start,
4259 Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
4268 - reganode - emit a node with an argument
4270 STATIC regnode * /* Location. */
4271 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
4273 register regnode *ret;
4274 register regnode *ptr;
4278 SIZE_ALIGN(RExC_size);
4283 NODE_ALIGN_FILL(ret);
4285 FILL_ADVANCE_NODE_ARG(ptr, op, arg);
4286 if (RExC_offsets) { /* MJD */
4287 MJD_OFFSET_DEBUG((stderr, "%s: %s %u <- %u (max %u).\n",
4289 RExC_emit - RExC_emit_start > RExC_offsets[0] ?
4290 "Overwriting end of array!\n" : "OK",
4291 RExC_emit - RExC_emit_start,
4292 RExC_parse - RExC_start,
4294 Set_Cur_Node_Offset;
4303 - reguni - emit (if appropriate) a Unicode character
4306 S_reguni(pTHX_ RExC_state_t *pRExC_state, UV uv, char* s, STRLEN* lenp)
4308 *lenp = SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
4312 - reginsert - insert an operator in front of already-emitted operand
4314 * Means relocating the operand.
4317 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd)
4319 register regnode *src;
4320 register regnode *dst;
4321 register regnode *place;
4322 register int offset = regarglen[(U8)op];
4324 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
4327 RExC_size += NODE_STEP_REGNODE + offset;
4332 RExC_emit += NODE_STEP_REGNODE + offset;
4334 while (src > opnd) {
4335 StructCopy(--src, --dst, regnode);
4336 if (RExC_offsets) { /* MJD 20010112 */
4337 MJD_OFFSET_DEBUG((stderr, "%s: %s copy %u -> %u (max %u).\n",
4339 dst - RExC_emit_start > RExC_offsets[0]
4340 ? "Overwriting end of array!\n" : "OK",
4341 src - RExC_emit_start,
4342 dst - RExC_emit_start,
4344 Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
4345 Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
4350 place = opnd; /* Op node, where operand used to be. */
4351 if (RExC_offsets) { /* MJD */
4352 MJD_OFFSET_DEBUG((stderr, "%s: %s %u <- %u (max %u).\n",
4354 place - RExC_emit_start > RExC_offsets[0]
4355 ? "Overwriting end of array!\n" : "OK",
4356 place - RExC_emit_start,
4357 RExC_parse - RExC_start,
4359 Set_Node_Offset(place, RExC_parse);
4361 src = NEXTOPER(place);
4362 FILL_ADVANCE_NODE(place, op);
4363 Zero(src, offset, regnode);
4367 - regtail - set the next-pointer at the end of a node chain of p to val.
4370 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, regnode *val)
4372 register regnode *scan;
4373 register regnode *temp;
4378 /* Find last node. */
4381 temp = regnext(scan);
4387 if (reg_off_by_arg[OP(scan)]) {
4388 ARG_SET(scan, val - scan);
4391 NEXT_OFF(scan) = val - scan;
4396 - regoptail - regtail on operand of first argument; nop if operandless
4399 S_regoptail(pTHX_ RExC_state_t *pRExC_state, regnode *p, regnode *val)
4401 /* "Operandless" and "op != BRANCH" are synonymous in practice. */
4402 if (p == NULL || SIZE_ONLY)
4404 if (PL_regkind[(U8)OP(p)] == BRANCH) {
4405 regtail(pRExC_state, NEXTOPER(p), val);
4407 else if ( PL_regkind[(U8)OP(p)] == BRANCHJ) {
4408 regtail(pRExC_state, NEXTOPER(NEXTOPER(p)), val);
4415 - regcurly - a little FSA that accepts {\d+,?\d*}
4418 S_regcurly(pTHX_ register char *s)
4439 S_dumpuntil(pTHX_ regnode *start, regnode *node, regnode *last, SV* sv, I32 l)
4441 register U8 op = EXACT; /* Arbitrary non-END op. */
4442 register regnode *next;
4444 while (op != END && (!last || node < last)) {
4445 /* While that wasn't END last time... */
4451 next = regnext(node);
4453 if (OP(node) == OPTIMIZED)
4456 PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
4457 (int)(2*l + 1), "", SvPVX(sv));
4458 if (next == NULL) /* Next ptr. */
4459 PerlIO_printf(Perl_debug_log, "(0)");
4461 PerlIO_printf(Perl_debug_log, "(%"IVdf")", (IV)(next - start));
4462 (void)PerlIO_putc(Perl_debug_log, '\n');
4464 if (PL_regkind[(U8)op] == BRANCHJ) {
4465 register regnode *nnode = (OP(next) == LONGJMP
4468 if (last && nnode > last)
4470 node = dumpuntil(start, NEXTOPER(NEXTOPER(node)), nnode, sv, l + 1);
4472 else if (PL_regkind[(U8)op] == BRANCH) {
4473 node = dumpuntil(start, NEXTOPER(node), next, sv, l + 1);
4475 else if ( op == CURLY) { /* `next' might be very big: optimizer */
4476 node = dumpuntil(start, NEXTOPER(node) + EXTRA_STEP_2ARGS,
4477 NEXTOPER(node) + EXTRA_STEP_2ARGS + 1, sv, l + 1);
4479 else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
4480 node = dumpuntil(start, NEXTOPER(node) + EXTRA_STEP_2ARGS,
4483 else if ( op == PLUS || op == STAR) {
4484 node = dumpuntil(start, NEXTOPER(node), NEXTOPER(node) + 1, sv, l + 1);
4486 else if (op == ANYOF) {
4487 /* arglen 1 + class block */
4488 node += 1 + ((ANYOF_FLAGS(node) & ANYOF_LARGE)
4489 ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
4490 node = NEXTOPER(node);
4492 else if (PL_regkind[(U8)op] == EXACT) {
4493 /* Literal string, where present. */
4494 node += NODE_SZ_STR(node) - 1;
4495 node = NEXTOPER(node);
4498 node = NEXTOPER(node);
4499 node += regarglen[(U8)op];
4501 if (op == CURLYX || op == OPEN)
4503 else if (op == WHILEM)
4509 #endif /* DEBUGGING */
4512 - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
4515 Perl_regdump(pTHX_ regexp *r)
4518 SV *sv = sv_newmortal();
4520 (void)dumpuntil(r->program, r->program + 1, NULL, sv, 0);
4522 /* Header fields of interest. */
4523 if (r->anchored_substr)
4524 PerlIO_printf(Perl_debug_log,
4525 "anchored `%s%.*s%s'%s at %"IVdf" ",
4527 (int)(SvCUR(r->anchored_substr) - (SvTAIL(r->anchored_substr)!=0)),
4528 SvPVX(r->anchored_substr),
4530 SvTAIL(r->anchored_substr) ? "$" : "",
4531 (IV)r->anchored_offset);
4532 if (r->float_substr)
4533 PerlIO_printf(Perl_debug_log,
4534 "floating `%s%.*s%s'%s at %"IVdf"..%"UVuf" ",
4536 (int)(SvCUR(r->float_substr) - (SvTAIL(r->float_substr)!=0)),
4537 SvPVX(r->float_substr),
4539 SvTAIL(r->float_substr) ? "$" : "",
4540 (IV)r->float_min_offset, (UV)r->float_max_offset);
4541 if (r->check_substr)
4542 PerlIO_printf(Perl_debug_log,
4543 r->check_substr == r->float_substr
4544 ? "(checking floating" : "(checking anchored");
4545 if (r->reganch & ROPT_NOSCAN)
4546 PerlIO_printf(Perl_debug_log, " noscan");
4547 if (r->reganch & ROPT_CHECK_ALL)
4548 PerlIO_printf(Perl_debug_log, " isall");
4549 if (r->check_substr)
4550 PerlIO_printf(Perl_debug_log, ") ");
4552 if (r->regstclass) {
4553 regprop(sv, r->regstclass);
4554 PerlIO_printf(Perl_debug_log, "stclass `%s' ", SvPVX(sv));
4556 if (r->reganch & ROPT_ANCH) {
4557 PerlIO_printf(Perl_debug_log, "anchored");
4558 if (r->reganch & ROPT_ANCH_BOL)
4559 PerlIO_printf(Perl_debug_log, "(BOL)");
4560 if (r->reganch & ROPT_ANCH_MBOL)
4561 PerlIO_printf(Perl_debug_log, "(MBOL)");
4562 if (r->reganch & ROPT_ANCH_SBOL)
4563 PerlIO_printf(Perl_debug_log, "(SBOL)");
4564 if (r->reganch & ROPT_ANCH_GPOS)
4565 PerlIO_printf(Perl_debug_log, "(GPOS)");
4566 PerlIO_putc(Perl_debug_log, ' ');
4568 if (r->reganch & ROPT_GPOS_SEEN)
4569 PerlIO_printf(Perl_debug_log, "GPOS ");
4570 if (r->reganch & ROPT_SKIP)
4571 PerlIO_printf(Perl_debug_log, "plus ");
4572 if (r->reganch & ROPT_IMPLICIT)
4573 PerlIO_printf(Perl_debug_log, "implicit ");
4574 PerlIO_printf(Perl_debug_log, "minlen %ld ", (long) r->minlen);
4575 if (r->reganch & ROPT_EVAL_SEEN)
4576 PerlIO_printf(Perl_debug_log, "with eval ");
4577 PerlIO_printf(Perl_debug_log, "\n");
4580 U32 len = r->offsets[0];
4581 PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)r->offsets[0]);
4582 for (i = 1; i <= len; i++)
4583 PerlIO_printf(Perl_debug_log, "%"UVuf"[%"UVuf"] ",
4584 (UV)r->offsets[i*2-1],
4585 (UV)r->offsets[i*2]);
4586 PerlIO_printf(Perl_debug_log, "\n");
4588 #endif /* DEBUGGING */
4594 S_put_byte(pTHX_ SV *sv, int c)
4596 if (isCNTRL(c) || c == 255 || !isPRINT(c))
4597 Perl_sv_catpvf(aTHX_ sv, "\\%o", c);
4598 else if (c == '-' || c == ']' || c == '\\' || c == '^')
4599 Perl_sv_catpvf(aTHX_ sv, "\\%c", c);
4601 Perl_sv_catpvf(aTHX_ sv, "%c", c);
4604 #endif /* DEBUGGING */
4607 - regprop - printable representation of opcode
4610 Perl_regprop(pTHX_ SV *sv, regnode *o)
4615 sv_setpvn(sv, "", 0);
4616 if (OP(o) >= reg_num) /* regnode.type is unsigned */
4617 /* It would be nice to FAIL() here, but this may be called from
4618 regexec.c, and it would be hard to supply pRExC_state. */
4619 Perl_croak(aTHX_ "Corrupted regexp opcode");
4620 sv_catpv(sv, (char*)reg_name[OP(o)]); /* Take off const! */
4622 k = PL_regkind[(U8)OP(o)];
4625 SV *dsv = sv_2mortal(newSVpvn("", 0));
4626 /* Using is_utf8_string() is a crude hack but it may
4627 * be the best for now since we have no flag "this EXACTish
4628 * node was UTF-8" --jhi */
4629 bool do_utf8 = is_utf8_string((U8*)STRING(o), STR_LEN(o));
4631 pv_uni_display(dsv, (U8*)STRING(o), STR_LEN(o), 60,
4632 UNI_DISPLAY_REGEX) :
4637 Perl_sv_catpvf(aTHX_ sv, " <%s%.*s%s>",
4642 else if (k == CURLY) {
4643 if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
4644 Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
4645 Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
4647 else if (k == WHILEM && o->flags) /* Ordinal/of */
4648 Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
4649 else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP )
4650 Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o)); /* Parenth number */
4651 else if (k == LOGICAL)
4652 Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* 2: embedded, otherwise 1 */
4653 else if (k == ANYOF) {
4654 int i, rangestart = -1;
4655 U8 flags = ANYOF_FLAGS(o);
4656 const char * const anyofs[] = { /* Should be syncronized with
4657 * ANYOF_ #xdefines in regcomp.h */
4690 if (flags & ANYOF_LOCALE)
4691 sv_catpv(sv, "{loc}");
4692 if (flags & ANYOF_FOLD)
4693 sv_catpv(sv, "{i}");
4694 Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
4695 if (flags & ANYOF_INVERT)
4697 for (i = 0; i <= 256; i++) {
4698 if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
4699 if (rangestart == -1)
4701 } else if (rangestart != -1) {
4702 if (i <= rangestart + 3)
4703 for (; rangestart < i; rangestart++)
4704 put_byte(sv, rangestart);
4706 put_byte(sv, rangestart);
4708 put_byte(sv, i - 1);
4714 if (o->flags & ANYOF_CLASS)
4715 for (i = 0; i < sizeof(anyofs)/sizeof(char*); i++)
4716 if (ANYOF_CLASS_TEST(o,i))
4717 sv_catpv(sv, anyofs[i]);
4719 if (flags & ANYOF_UNICODE)
4720 sv_catpv(sv, "{unicode}");
4721 else if (flags & ANYOF_UNICODE_ALL)
4722 sv_catpv(sv, "{unicode_all}");
4726 SV *sw = regclass_swash(o, FALSE, &lv, 0);
4731 U8 s[UTF8_MAXLEN+1];
4733 for (i = 0; i <= 256; i++) { /* just the first 256 */
4734 U8 *e = uvchr_to_utf8(s, i);
4736 if (i < 256 && swash_fetch(sw, s, TRUE)) {
4737 if (rangestart == -1)
4739 } else if (rangestart != -1) {
4742 if (i <= rangestart + 3)
4743 for (; rangestart < i; rangestart++) {
4744 for(e = uvchr_to_utf8(s, rangestart), p = s; p < e; p++)
4748 for (e = uvchr_to_utf8(s, rangestart), p = s; p < e; p++)
4751 for (e = uvchr_to_utf8(s, i - 1), p = s; p < e; p++)
4758 sv_catpv(sv, "..."); /* et cetera */
4762 char *s = savepv(SvPVX(lv));
4765 while(*s && *s != '\n') s++;
4786 Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
4788 else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
4789 Perl_sv_catpvf(aTHX_ sv, "[-%d]", o->flags);
4790 #endif /* DEBUGGING */
4794 Perl_re_intuit_string(pTHX_ regexp *prog)
4795 { /* Assume that RE_INTUIT is set */
4798 char *s = SvPV(prog->check_substr,n_a);
4800 if (!PL_colorset) reginitcolors();
4801 PerlIO_printf(Perl_debug_log,
4802 "%sUsing REx substr:%s `%s%.60s%s%s'\n",
4803 PL_colors[4],PL_colors[5],PL_colors[0],
4806 (strlen(s) > 60 ? "..." : ""));
4809 return prog->check_substr;
4813 Perl_pregfree(pTHX_ struct regexp *r)
4816 SV *dsv = PERL_DEBUG_PAD_ZERO(0);
4819 if (!r || (--r->refcnt > 0))
4822 char *s = pv_uni_display(dsv, (U8*)r->precomp, r->prelen, 60,
4824 int len = SvCUR(dsv);
4827 PerlIO_printf(Perl_debug_log,
4828 "%sFreeing REx:%s `%s%*.*s%s%s'\n",
4829 PL_colors[4],PL_colors[5],PL_colors[0],
4832 len > 60 ? "..." : "");
4836 Safefree(r->precomp);
4837 if (r->offsets) /* 20010421 MJD */
4838 Safefree(r->offsets);
4839 if (RX_MATCH_COPIED(r))
4840 Safefree(r->subbeg);
4842 if (r->anchored_substr)
4843 SvREFCNT_dec(r->anchored_substr);
4844 if (r->float_substr)
4845 SvREFCNT_dec(r->float_substr);
4846 Safefree(r->substrs);
4849 int n = r->data->count;
4850 AV* new_comppad = NULL;
4855 /* If you add a ->what type here, update the comment in regcomp.h */
4856 switch (r->data->what[n]) {
4858 SvREFCNT_dec((SV*)r->data->data[n]);
4861 Safefree(r->data->data[n]);
4864 new_comppad = (AV*)r->data->data[n];
4867 if (new_comppad == NULL)
4868 Perl_croak(aTHX_ "panic: pregfree comppad");
4869 old_comppad = PL_comppad;
4870 old_curpad = PL_curpad;
4871 /* Watch out for global destruction's random ordering. */
4872 if (SvTYPE(new_comppad) == SVt_PVAV) {
4873 PL_comppad = new_comppad;
4874 PL_curpad = AvARRAY(new_comppad);
4879 if (!OpREFCNT_dec((OP_4tree*)r->data->data[n])) {
4880 op_free((OP_4tree*)r->data->data[n]);
4883 PL_comppad = old_comppad;
4884 PL_curpad = old_curpad;
4885 SvREFCNT_dec((SV*)new_comppad);
4891 Perl_croak(aTHX_ "panic: regfree data code '%c'", r->data->what[n]);
4894 Safefree(r->data->what);
4897 Safefree(r->startp);
4903 - regnext - dig the "next" pointer out of a node
4905 * [Note, when REGALIGN is defined there are two places in regmatch()
4906 * that bypass this code for speed.]
4909 Perl_regnext(pTHX_ register regnode *p)
4911 register I32 offset;
4913 if (p == &PL_regdummy)
4916 offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
4924 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
4927 STRLEN l1 = strlen(pat1);
4928 STRLEN l2 = strlen(pat2);
4937 Copy(pat1, buf, l1 , char);
4938 Copy(pat2, buf + l1, l2 , char);
4939 buf[l1 + l2] = '\n';
4940 buf[l1 + l2 + 1] = '\0';
4942 /* ANSI variant takes additional second argument */
4943 va_start(args, pat2);
4947 msv = vmess(buf, &args);
4949 message = SvPV(msv,l1);
4952 Copy(message, buf, l1 , char);
4953 buf[l1] = '\0'; /* Overwrite \n */
4954 Perl_croak(aTHX_ "%s", buf);
4957 /* XXX Here's a total kludge. But we need to re-enter for swash routines. */
4960 Perl_save_re_context(pTHX)
4963 SAVEPPTR(RExC_precomp); /* uncompiled string. */
4964 SAVEI32(RExC_npar); /* () count. */
4965 SAVEI32(RExC_size); /* Code size. */
4966 SAVEI16(RExC_flags16); /* are we folding, multilining? */
4967 SAVEVPTR(RExC_rx); /* from regcomp.c */
4968 SAVEI32(RExC_seen); /* from regcomp.c */
4969 SAVEI32(RExC_sawback); /* Did we see \1, ...? */
4970 SAVEI32(RExC_naughty); /* How bad is this pattern? */
4971 SAVEVPTR(RExC_emit); /* Code-emit pointer; ®dummy = don't */
4972 SAVEPPTR(RExC_end); /* End of input for compile */
4973 SAVEPPTR(RExC_parse); /* Input-scan pointer. */
4976 SAVEI32(PL_reg_flags); /* from regexec.c */
4978 SAVEPPTR(PL_reginput); /* String-input pointer. */
4979 SAVEPPTR(PL_regbol); /* Beginning of input, for ^ check. */
4980 SAVEPPTR(PL_regeol); /* End of input, for $ check. */
4981 SAVEVPTR(PL_regstartp); /* Pointer to startp array. */
4982 SAVEVPTR(PL_regendp); /* Ditto for endp. */
4983 SAVEVPTR(PL_reglastparen); /* Similarly for lastparen. */
4984 SAVEPPTR(PL_regtill); /* How far we are required to go. */
4985 SAVEGENERICPV(PL_reg_start_tmp); /* from regexec.c */
4986 PL_reg_start_tmp = 0;
4987 SAVEI32(PL_reg_start_tmpl); /* from regexec.c */
4988 PL_reg_start_tmpl = 0;
4989 SAVEVPTR(PL_regdata);
4990 SAVEI32(PL_reg_eval_set); /* from regexec.c */
4991 SAVEI32(PL_regnarrate); /* from regexec.c */
4992 SAVEVPTR(PL_regprogram); /* from regexec.c */
4993 SAVEINT(PL_regindent); /* from regexec.c */
4994 SAVEVPTR(PL_regcc); /* from regexec.c */
4995 SAVEVPTR(PL_curcop);
4996 SAVEVPTR(PL_reg_call_cc); /* from regexec.c */
4997 SAVEVPTR(PL_reg_re); /* from regexec.c */
4998 SAVEPPTR(PL_reg_ganch); /* from regexec.c */
4999 SAVESPTR(PL_reg_sv); /* from regexec.c */
5000 SAVEI8(PL_reg_match_utf8); /* from regexec.c */
5001 SAVEVPTR(PL_reg_magic); /* from regexec.c */
5002 SAVEI32(PL_reg_oldpos); /* from regexec.c */
5003 SAVEVPTR(PL_reg_oldcurpm); /* from regexec.c */
5004 SAVEVPTR(PL_reg_curpm); /* from regexec.c */
5005 SAVEI32(PL_regnpar); /* () count. */
5006 SAVEI32(PL_regsize); /* from regexec.c */
5008 SAVEPPTR(PL_reg_starttry); /* from regexec.c */
5013 clear_re(pTHX_ void *r)
5015 ReREFCNT_dec((regexp *)r);