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_ packWARN(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 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP), "%s" REPORT_LOCATION,\
396 m, (int)offset, RExC_precomp, RExC_precomp + offset); \
400 #define vWARN2(loc, m, a1) \
402 IV offset = loc - RExC_precomp; \
403 Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,\
405 (int)offset, RExC_precomp, RExC_precomp + offset); \
408 #define vWARN3(loc, m, a1, a2) \
410 IV offset = loc - RExC_precomp; \
411 Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
413 (int)offset, RExC_precomp, RExC_precomp + offset); \
416 #define vWARN4(loc, m, a1, a2, a3) \
418 IV offset = loc - RExC_precomp; \
419 Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,\
421 (int)offset, RExC_precomp, RExC_precomp + offset); \
424 /* used for the parse_flags section for (?c) -- japhy */
425 #define vWARN5(loc, m, a1, a2, a3, a4) \
427 IV offset = loc - RExC_precomp; \
428 Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
430 (int)offset, RExC_precomp, RExC_precomp + offset); \
434 /* Allow for side effects in s */
435 #define REGC(c,s) STMT_START { if (!SIZE_ONLY) *(s) = (c); else (void)(s);} STMT_END
437 /* Macros for recording node offsets. 20001227 mjd@plover.com
438 * Nodes are numbered 1, 2, 3, 4. Node #n's position is recorded in
439 * element 2*n-1 of the array. Element #2n holds the byte length node #n.
440 * Element 0 holds the number n.
443 #define MJD_OFFSET_DEBUG(x)
444 /* #define MJD_OFFSET_DEBUG(x) fprintf x */
447 # define Set_Node_Offset_To_R(node,byte) \
451 Perl_croak(aTHX_ "value of node is %d in Offset macro", node); \
453 RExC_offsets[2*(node)-1] = (byte); \
458 # define Set_Node_Offset(node,byte) Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
459 # define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
461 # define Set_Node_Length_To_R(node,len) \
464 MJD_OFFSET_DEBUG((stderr, "** (%d) size of node %d is %d.\n", __LINE__, (node), (len))); \
466 Perl_croak(aTHX_ "value of node is %d in Length macro", node); \
468 RExC_offsets[2*(node)] = (len); \
473 # define Set_Node_Length(node,len) Set_Node_Length_To_R((node)-RExC_emit_start, len)
474 # define Set_Cur_Node_Length(len) Set_Node_Length(RExC_emit, len)
475 # define Set_Node_Cur_Length(node) Set_Node_Length(node, RExC_parse - parse_start)
477 /* Get offsets and lengths */
478 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
479 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
481 static void clear_re(pTHX_ void *r);
483 /* Mark that we cannot extend a found fixed substring at this point.
484 Updata the longest found anchored substring and the longest found
485 floating substrings if needed. */
488 S_scan_commit(pTHX_ RExC_state_t *pRExC_state, scan_data_t *data)
490 STRLEN l = CHR_SVLEN(data->last_found);
491 STRLEN old_l = CHR_SVLEN(*data->longest);
493 if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
494 sv_setsv(*data->longest, data->last_found);
495 if (*data->longest == data->longest_fixed) {
496 data->offset_fixed = l ? data->last_start_min : data->pos_min;
497 if (data->flags & SF_BEFORE_EOL)
499 |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
501 data->flags &= ~SF_FIX_BEFORE_EOL;
504 data->offset_float_min = l ? data->last_start_min : data->pos_min;
505 data->offset_float_max = (l
506 ? data->last_start_max
507 : data->pos_min + data->pos_delta);
508 if ((U32)data->offset_float_max > (U32)I32_MAX)
509 data->offset_float_max = I32_MAX;
510 if (data->flags & SF_BEFORE_EOL)
512 |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
514 data->flags &= ~SF_FL_BEFORE_EOL;
517 SvCUR_set(data->last_found, 0);
519 data->flags &= ~SF_BEFORE_EOL;
522 /* Can match anything (initialization) */
524 S_cl_anything(pTHX_ RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
526 ANYOF_CLASS_ZERO(cl);
527 ANYOF_BITMAP_SETALL(cl);
528 cl->flags = ANYOF_EOS|ANYOF_UNICODE_ALL;
530 cl->flags |= ANYOF_LOCALE;
533 /* Can match anything (initialization) */
535 S_cl_is_anything(pTHX_ struct regnode_charclass_class *cl)
539 for (value = 0; value <= ANYOF_MAX; value += 2)
540 if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
542 if (!(cl->flags & ANYOF_UNICODE_ALL))
544 if (!ANYOF_BITMAP_TESTALLSET(cl))
549 /* Can match anything (initialization) */
551 S_cl_init(pTHX_ RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
553 Zero(cl, 1, struct regnode_charclass_class);
555 cl_anything(pRExC_state, cl);
559 S_cl_init_zero(pTHX_ RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
561 Zero(cl, 1, struct regnode_charclass_class);
563 cl_anything(pRExC_state, cl);
565 cl->flags |= ANYOF_LOCALE;
568 /* 'And' a given class with another one. Can create false positives */
569 /* We assume that cl is not inverted */
571 S_cl_and(pTHX_ struct regnode_charclass_class *cl,
572 struct regnode_charclass_class *and_with)
574 if (!(and_with->flags & ANYOF_CLASS)
575 && !(cl->flags & ANYOF_CLASS)
576 && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
577 && !(and_with->flags & ANYOF_FOLD)
578 && !(cl->flags & ANYOF_FOLD)) {
581 if (and_with->flags & ANYOF_INVERT)
582 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
583 cl->bitmap[i] &= ~and_with->bitmap[i];
585 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
586 cl->bitmap[i] &= and_with->bitmap[i];
587 } /* XXXX: logic is complicated otherwise, leave it along for a moment. */
588 if (!(and_with->flags & ANYOF_EOS))
589 cl->flags &= ~ANYOF_EOS;
591 if (cl->flags & ANYOF_UNICODE_ALL && and_with->flags & ANYOF_UNICODE) {
592 cl->flags &= ~ANYOF_UNICODE_ALL;
593 cl->flags |= ANYOF_UNICODE;
594 ARG_SET(cl, ARG(and_with));
596 if (!(and_with->flags & ANYOF_UNICODE_ALL))
597 cl->flags &= ~ANYOF_UNICODE_ALL;
598 if (!(and_with->flags & (ANYOF_UNICODE|ANYOF_UNICODE_ALL)))
599 cl->flags &= ~ANYOF_UNICODE;
602 /* 'OR' a given class with another one. Can create false positives */
603 /* We assume that cl is not inverted */
605 S_cl_or(pTHX_ RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, struct regnode_charclass_class *or_with)
607 if (or_with->flags & ANYOF_INVERT) {
609 * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2))
610 * <= (B1 | !B2) | (CL1 | !CL2)
611 * which is wasteful if CL2 is small, but we ignore CL2:
612 * (B1 | CL1) | (!B2 & !CL2) <= (B1 | CL1) | !B2 = (B1 | !B2) | CL1
613 * XXXX Can we handle case-fold? Unclear:
614 * (OK1(i) | OK1(i')) | !(OK1(i) | OK1(i')) =
615 * (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i'))
617 if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
618 && !(or_with->flags & ANYOF_FOLD)
619 && !(cl->flags & ANYOF_FOLD) ) {
622 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
623 cl->bitmap[i] |= ~or_with->bitmap[i];
624 } /* XXXX: logic is complicated otherwise */
626 cl_anything(pRExC_state, cl);
629 /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
630 if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
631 && (!(or_with->flags & ANYOF_FOLD)
632 || (cl->flags & ANYOF_FOLD)) ) {
635 /* OR char bitmap and class bitmap separately */
636 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
637 cl->bitmap[i] |= or_with->bitmap[i];
638 if (or_with->flags & ANYOF_CLASS) {
639 for (i = 0; i < ANYOF_CLASSBITMAP_SIZE; i++)
640 cl->classflags[i] |= or_with->classflags[i];
641 cl->flags |= ANYOF_CLASS;
644 else { /* XXXX: logic is complicated, leave it along for a moment. */
645 cl_anything(pRExC_state, cl);
648 if (or_with->flags & ANYOF_EOS)
649 cl->flags |= ANYOF_EOS;
651 if (cl->flags & ANYOF_UNICODE && or_with->flags & ANYOF_UNICODE &&
652 ARG(cl) != ARG(or_with)) {
653 cl->flags |= ANYOF_UNICODE_ALL;
654 cl->flags &= ~ANYOF_UNICODE;
656 if (or_with->flags & ANYOF_UNICODE_ALL) {
657 cl->flags |= ANYOF_UNICODE_ALL;
658 cl->flags &= ~ANYOF_UNICODE;
663 * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
664 * These need to be revisited when a newer toolchain becomes available.
666 #if defined(__sparc64__) && defined(__GNUC__)
667 # if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
668 # undef SPARC64_GCC_WORKAROUND
669 # define SPARC64_GCC_WORKAROUND 1
673 /* REx optimizer. Converts nodes into quickier variants "in place".
674 Finds fixed substrings. */
676 /* Stops at toplevel WHILEM as well as at `last'. At end *scanp is set
677 to the position after last scanned or to NULL. */
680 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, regnode *last, scan_data_t *data, U32 flags)
681 /* scanp: Start here (read-write). */
682 /* deltap: Write maxlen-minlen here. */
683 /* last: Stop before this one. */
685 I32 min = 0, pars = 0, code;
686 regnode *scan = *scanp, *next;
688 int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
689 int is_inf_internal = 0; /* The studied chunk is infinite */
690 I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
691 scan_data_t data_fake;
692 struct regnode_charclass_class and_with; /* Valid if flags & SCF_DO_STCLASS_OR */
694 while (scan && OP(scan) != END && scan < last) {
695 /* Peephole optimizer: */
697 if (PL_regkind[(U8)OP(scan)] == EXACT) {
698 /* Merge several consecutive EXACTish nodes into one. */
699 regnode *n = regnext(scan);
702 regnode *stop = scan;
705 next = scan + NODE_SZ_STR(scan);
706 /* Skip NOTHING, merge EXACT*. */
708 ( PL_regkind[(U8)OP(n)] == NOTHING ||
709 (stringok && (OP(n) == OP(scan))))
711 && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX) {
712 if (OP(n) == TAIL || n > next)
714 if (PL_regkind[(U8)OP(n)] == NOTHING) {
715 NEXT_OFF(scan) += NEXT_OFF(n);
716 next = n + NODE_STEP_REGNODE;
724 int oldl = STR_LEN(scan);
725 regnode *nnext = regnext(n);
727 if (oldl + STR_LEN(n) > U8_MAX)
729 NEXT_OFF(scan) += NEXT_OFF(n);
730 STR_LEN(scan) += STR_LEN(n);
731 next = n + NODE_SZ_STR(n);
732 /* Now we can overwrite *n : */
733 Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
741 if (UTF && OP(scan) == EXACTF && STR_LEN(scan) >= 6) {
743 Two problematic code points in Unicode casefolding of EXACT nodes:
745 U+0390 - GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
746 U+03B0 - GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
752 U+03B9 U+0308 U+0301 0xCE 0xB9 0xCC 0x88 0xCC 0x81
753 U+03C5 U+0308 U+0301 0xCF 0x85 0xCC 0x88 0xCC 0x81
755 This means that in case-insensitive matching (or "loose matching",
756 as Unicode calls it), an EXACTF of length six (the UTF-8 encoded byte
757 length of the above casefolded versions) can match a target string
758 of length two (the byte length of UTF-8 encoded U+0390 or U+03B0).
759 This would rather mess up the minimum length computation.
761 What we'll do is to look for the tail four bytes, and then peek
762 at the preceding two bytes to see whether we need to decrease
763 the minimum length by four (six minus two).
765 Thanks to the design of UTF-8, there cannot be false matches:
766 A sequence of valid UTF-8 bytes cannot be a subsequence of
767 another valid sequence of UTF-8 bytes.
770 char *s0 = STRING(scan), *s, *t;
771 char *s1 = s0 + STR_LEN(scan) - 1, *s2 = s1 - 4;
772 char *t0 = "\xcc\x88\xcc\x81";
776 s < s2 && (t = ninstr(s, s1, t0, t1));
778 if (((U8)t[-1] == 0xB9 && (U8)t[-2] == 0xCE) ||
779 ((U8)t[-1] == 0x85 && (U8)t[-2] == 0xCF))
786 n = scan + NODE_SZ_STR(scan);
788 if (PL_regkind[(U8)OP(n)] != NOTHING || OP(n) == NOTHING) {
796 /* Follow the next-chain of the current node and optimize
797 away all the NOTHINGs from it. */
798 if (OP(scan) != CURLYX) {
799 int max = (reg_off_by_arg[OP(scan)]
801 /* I32 may be smaller than U16 on CRAYs! */
802 : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
803 int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
807 /* Skip NOTHING and LONGJMP. */
808 while ((n = regnext(n))
809 && ((PL_regkind[(U8)OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
810 || ((OP(n) == LONGJMP) && (noff = ARG(n))))
813 if (reg_off_by_arg[OP(scan)])
816 NEXT_OFF(scan) = off;
818 /* The principal pseudo-switch. Cannot be a switch, since we
819 look into several different things. */
820 if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
821 || OP(scan) == IFTHEN || OP(scan) == SUSPEND) {
822 next = regnext(scan);
825 if (OP(next) == code || code == IFTHEN || code == SUSPEND) {
826 I32 max1 = 0, min1 = I32_MAX, num = 0;
827 struct regnode_charclass_class accum;
829 if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
830 scan_commit(pRExC_state, data); /* Cannot merge strings after this. */
831 if (flags & SCF_DO_STCLASS)
832 cl_init_zero(pRExC_state, &accum);
833 while (OP(scan) == code) {
834 I32 deltanext, minnext, f = 0, fake;
835 struct regnode_charclass_class this_class;
840 data_fake.whilem_c = data->whilem_c;
841 data_fake.last_closep = data->last_closep;
844 data_fake.last_closep = &fake;
845 next = regnext(scan);
846 scan = NEXTOPER(scan);
848 scan = NEXTOPER(scan);
849 if (flags & SCF_DO_STCLASS) {
850 cl_init(pRExC_state, &this_class);
851 data_fake.start_class = &this_class;
852 f = SCF_DO_STCLASS_AND;
854 if (flags & SCF_WHILEM_VISITED_POS)
855 f |= SCF_WHILEM_VISITED_POS;
856 /* we suppose the run is continuous, last=next...*/
857 minnext = study_chunk(pRExC_state, &scan, &deltanext,
858 next, &data_fake, f);
861 if (max1 < minnext + deltanext)
862 max1 = minnext + deltanext;
863 if (deltanext == I32_MAX)
864 is_inf = is_inf_internal = 1;
866 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
868 if (data && (data_fake.flags & SF_HAS_EVAL))
869 data->flags |= SF_HAS_EVAL;
871 data->whilem_c = data_fake.whilem_c;
872 if (flags & SCF_DO_STCLASS)
873 cl_or(pRExC_state, &accum, &this_class);
877 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
879 if (flags & SCF_DO_SUBSTR) {
880 data->pos_min += min1;
881 data->pos_delta += max1 - min1;
882 if (max1 != min1 || is_inf)
883 data->longest = &(data->longest_float);
886 delta += max1 - min1;
887 if (flags & SCF_DO_STCLASS_OR) {
888 cl_or(pRExC_state, data->start_class, &accum);
890 cl_and(data->start_class, &and_with);
891 flags &= ~SCF_DO_STCLASS;
894 else if (flags & SCF_DO_STCLASS_AND) {
896 cl_and(data->start_class, &accum);
897 flags &= ~SCF_DO_STCLASS;
900 /* Switch to OR mode: cache the old value of
901 * data->start_class */
902 StructCopy(data->start_class, &and_with,
903 struct regnode_charclass_class);
904 flags &= ~SCF_DO_STCLASS_AND;
905 StructCopy(&accum, data->start_class,
906 struct regnode_charclass_class);
907 flags |= SCF_DO_STCLASS_OR;
908 data->start_class->flags |= ANYOF_EOS;
912 else if (code == BRANCHJ) /* single branch is optimized. */
913 scan = NEXTOPER(NEXTOPER(scan));
914 else /* single branch is optimized. */
915 scan = NEXTOPER(scan);
918 else if (OP(scan) == EXACT) {
919 I32 l = STR_LEN(scan);
920 UV uc = *((U8*)STRING(scan));
922 U8 *s = (U8*)STRING(scan);
923 l = utf8_length(s, s + l);
924 uc = utf8_to_uvchr(s, NULL);
927 if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
928 /* The code below prefers earlier match for fixed
929 offset, later match for variable offset. */
930 if (data->last_end == -1) { /* Update the start info. */
931 data->last_start_min = data->pos_min;
932 data->last_start_max = is_inf
933 ? I32_MAX : data->pos_min + data->pos_delta;
935 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
937 SvUTF8_on(data->last_found);
938 data->last_end = data->pos_min + l;
939 data->pos_min += l; /* As in the first entry. */
940 data->flags &= ~SF_BEFORE_EOL;
942 if (flags & SCF_DO_STCLASS_AND) {
943 /* Check whether it is compatible with what we know already! */
947 (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
948 && !ANYOF_BITMAP_TEST(data->start_class, uc)
949 && (!(data->start_class->flags & ANYOF_FOLD)
950 || !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc])))
953 ANYOF_CLASS_ZERO(data->start_class);
954 ANYOF_BITMAP_ZERO(data->start_class);
956 ANYOF_BITMAP_SET(data->start_class, uc);
957 data->start_class->flags &= ~ANYOF_EOS;
959 data->start_class->flags &= ~ANYOF_UNICODE_ALL;
961 else if (flags & SCF_DO_STCLASS_OR) {
962 /* false positive possible if the class is case-folded */
964 ANYOF_BITMAP_SET(data->start_class, uc);
966 data->start_class->flags |= ANYOF_UNICODE_ALL;
967 data->start_class->flags &= ~ANYOF_EOS;
968 cl_and(data->start_class, &and_with);
970 flags &= ~SCF_DO_STCLASS;
972 else if (PL_regkind[(U8)OP(scan)] == EXACT) { /* But OP != EXACT! */
973 I32 l = STR_LEN(scan);
974 UV uc = *((U8*)STRING(scan));
976 /* Search for fixed substrings supports EXACT only. */
977 if (flags & SCF_DO_SUBSTR)
978 scan_commit(pRExC_state, data);
980 U8 *s = (U8 *)STRING(scan);
981 l = utf8_length(s, s + l);
982 uc = utf8_to_uvchr(s, NULL);
985 if (data && (flags & SCF_DO_SUBSTR))
987 if (flags & SCF_DO_STCLASS_AND) {
988 /* Check whether it is compatible with what we know already! */
992 (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
993 && !ANYOF_BITMAP_TEST(data->start_class, uc)
994 && !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc])))
996 ANYOF_CLASS_ZERO(data->start_class);
997 ANYOF_BITMAP_ZERO(data->start_class);
999 ANYOF_BITMAP_SET(data->start_class, uc);
1000 data->start_class->flags &= ~ANYOF_EOS;
1001 data->start_class->flags |= ANYOF_FOLD;
1002 if (OP(scan) == EXACTFL)
1003 data->start_class->flags |= ANYOF_LOCALE;
1006 else if (flags & SCF_DO_STCLASS_OR) {
1007 if (data->start_class->flags & ANYOF_FOLD) {
1008 /* false positive possible if the class is case-folded.
1009 Assume that the locale settings are the same... */
1011 ANYOF_BITMAP_SET(data->start_class, uc);
1012 data->start_class->flags &= ~ANYOF_EOS;
1014 cl_and(data->start_class, &and_with);
1016 flags &= ~SCF_DO_STCLASS;
1018 else if (strchr((char*)PL_varies,OP(scan))) {
1019 I32 mincount, maxcount, minnext, deltanext, fl = 0;
1020 I32 f = flags, pos_before = 0;
1021 regnode *oscan = scan;
1022 struct regnode_charclass_class this_class;
1023 struct regnode_charclass_class *oclass = NULL;
1024 I32 next_is_eval = 0;
1026 switch (PL_regkind[(U8)OP(scan)]) {
1027 case WHILEM: /* End of (?:...)* . */
1028 scan = NEXTOPER(scan);
1031 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
1032 next = NEXTOPER(scan);
1033 if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
1035 maxcount = REG_INFTY;
1036 next = regnext(scan);
1037 scan = NEXTOPER(scan);
1041 if (flags & SCF_DO_SUBSTR)
1046 if (flags & SCF_DO_STCLASS) {
1048 maxcount = REG_INFTY;
1049 next = regnext(scan);
1050 scan = NEXTOPER(scan);
1053 is_inf = is_inf_internal = 1;
1054 scan = regnext(scan);
1055 if (flags & SCF_DO_SUBSTR) {
1056 scan_commit(pRExC_state, data); /* Cannot extend fixed substrings */
1057 data->longest = &(data->longest_float);
1059 goto optimize_curly_tail;
1061 mincount = ARG1(scan);
1062 maxcount = ARG2(scan);
1063 next = regnext(scan);
1064 if (OP(scan) == CURLYX) {
1065 I32 lp = (data ? *(data->last_closep) : 0);
1067 scan->flags = ((lp <= U8_MAX) ? lp : U8_MAX);
1069 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
1070 next_is_eval = (OP(scan) == EVAL);
1072 if (flags & SCF_DO_SUBSTR) {
1073 if (mincount == 0) scan_commit(pRExC_state,data); /* Cannot extend fixed substrings */
1074 pos_before = data->pos_min;
1078 data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
1080 data->flags |= SF_IS_INF;
1082 if (flags & SCF_DO_STCLASS) {
1083 cl_init(pRExC_state, &this_class);
1084 oclass = data->start_class;
1085 data->start_class = &this_class;
1086 f |= SCF_DO_STCLASS_AND;
1087 f &= ~SCF_DO_STCLASS_OR;
1089 /* These are the cases when once a subexpression
1090 fails at a particular position, it cannot succeed
1091 even after backtracking at the enclosing scope.
1093 XXXX what if minimal match and we are at the
1094 initial run of {n,m}? */
1095 if ((mincount != maxcount - 1) && (maxcount != REG_INFTY))
1096 f &= ~SCF_WHILEM_VISITED_POS;
1098 /* This will finish on WHILEM, setting scan, or on NULL: */
1099 minnext = study_chunk(pRExC_state, &scan, &deltanext, last, data,
1101 ? (f & ~SCF_DO_SUBSTR) : f);
1103 if (flags & SCF_DO_STCLASS)
1104 data->start_class = oclass;
1105 if (mincount == 0 || minnext == 0) {
1106 if (flags & SCF_DO_STCLASS_OR) {
1107 cl_or(pRExC_state, data->start_class, &this_class);
1109 else if (flags & SCF_DO_STCLASS_AND) {
1110 /* Switch to OR mode: cache the old value of
1111 * data->start_class */
1112 StructCopy(data->start_class, &and_with,
1113 struct regnode_charclass_class);
1114 flags &= ~SCF_DO_STCLASS_AND;
1115 StructCopy(&this_class, data->start_class,
1116 struct regnode_charclass_class);
1117 flags |= SCF_DO_STCLASS_OR;
1118 data->start_class->flags |= ANYOF_EOS;
1120 } else { /* Non-zero len */
1121 if (flags & SCF_DO_STCLASS_OR) {
1122 cl_or(pRExC_state, data->start_class, &this_class);
1123 cl_and(data->start_class, &and_with);
1125 else if (flags & SCF_DO_STCLASS_AND)
1126 cl_and(data->start_class, &this_class);
1127 flags &= ~SCF_DO_STCLASS;
1129 if (!scan) /* It was not CURLYX, but CURLY. */
1131 if (ckWARN(WARN_REGEXP)
1132 /* ? quantifier ok, except for (?{ ... }) */
1133 && (next_is_eval || !(mincount == 0 && maxcount == 1))
1134 && (minnext == 0) && (deltanext == 0)
1135 && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
1136 && maxcount <= REG_INFTY/3) /* Complement check for big count */
1139 "Quantifier unexpected on zero-length expression");
1142 min += minnext * mincount;
1143 is_inf_internal |= ((maxcount == REG_INFTY
1144 && (minnext + deltanext) > 0)
1145 || deltanext == I32_MAX);
1146 is_inf |= is_inf_internal;
1147 delta += (minnext + deltanext) * maxcount - minnext * mincount;
1149 /* Try powerful optimization CURLYX => CURLYN. */
1150 if ( OP(oscan) == CURLYX && data
1151 && data->flags & SF_IN_PAR
1152 && !(data->flags & SF_HAS_EVAL)
1153 && !deltanext && minnext == 1 ) {
1154 /* Try to optimize to CURLYN. */
1155 regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
1156 regnode *nxt1 = nxt;
1163 if (!strchr((char*)PL_simple,OP(nxt))
1164 && !(PL_regkind[(U8)OP(nxt)] == EXACT
1165 && STR_LEN(nxt) == 1))
1171 if (OP(nxt) != CLOSE)
1173 /* Now we know that nxt2 is the only contents: */
1174 oscan->flags = ARG(nxt);
1176 OP(nxt1) = NOTHING; /* was OPEN. */
1178 OP(nxt1 + 1) = OPTIMIZED; /* was count. */
1179 NEXT_OFF(nxt1+ 1) = 0; /* just for consistancy. */
1180 NEXT_OFF(nxt2) = 0; /* just for consistancy with CURLY. */
1181 OP(nxt) = OPTIMIZED; /* was CLOSE. */
1182 OP(nxt + 1) = OPTIMIZED; /* was count. */
1183 NEXT_OFF(nxt+ 1) = 0; /* just for consistancy. */
1188 /* Try optimization CURLYX => CURLYM. */
1189 if ( OP(oscan) == CURLYX && data
1190 && !(data->flags & SF_HAS_PAR)
1191 && !(data->flags & SF_HAS_EVAL)
1193 /* XXXX How to optimize if data == 0? */
1194 /* Optimize to a simpler form. */
1195 regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
1199 while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
1200 && (OP(nxt2) != WHILEM))
1202 OP(nxt2) = SUCCEED; /* Whas WHILEM */
1203 /* Need to optimize away parenths. */
1204 if (data->flags & SF_IN_PAR) {
1205 /* Set the parenth number. */
1206 regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
1208 if (OP(nxt) != CLOSE)
1209 FAIL("Panic opt close");
1210 oscan->flags = ARG(nxt);
1211 OP(nxt1) = OPTIMIZED; /* was OPEN. */
1212 OP(nxt) = OPTIMIZED; /* was CLOSE. */
1214 OP(nxt1 + 1) = OPTIMIZED; /* was count. */
1215 OP(nxt + 1) = OPTIMIZED; /* was count. */
1216 NEXT_OFF(nxt1 + 1) = 0; /* just for consistancy. */
1217 NEXT_OFF(nxt + 1) = 0; /* just for consistancy. */
1220 while ( nxt1 && (OP(nxt1) != WHILEM)) {
1221 regnode *nnxt = regnext(nxt1);
1224 if (reg_off_by_arg[OP(nxt1)])
1225 ARG_SET(nxt1, nxt2 - nxt1);
1226 else if (nxt2 - nxt1 < U16_MAX)
1227 NEXT_OFF(nxt1) = nxt2 - nxt1;
1229 OP(nxt) = NOTHING; /* Cannot beautify */
1234 /* Optimize again: */
1235 study_chunk(pRExC_state, &nxt1, &deltanext, nxt,
1241 else if ((OP(oscan) == CURLYX)
1242 && (flags & SCF_WHILEM_VISITED_POS)
1243 /* See the comment on a similar expression above.
1244 However, this time it not a subexpression
1245 we care about, but the expression itself. */
1246 && (maxcount == REG_INFTY)
1247 && data && ++data->whilem_c < 16) {
1248 /* This stays as CURLYX, we can put the count/of pair. */
1249 /* Find WHILEM (as in regexec.c) */
1250 regnode *nxt = oscan + NEXT_OFF(oscan);
1252 if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
1254 PREVOPER(nxt)->flags = data->whilem_c
1255 | (RExC_whilem_seen << 4); /* On WHILEM */
1257 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
1259 if (flags & SCF_DO_SUBSTR) {
1260 SV *last_str = Nullsv;
1261 int counted = mincount != 0;
1263 if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
1264 #if defined(SPARC64_GCC_WORKAROUND)
1270 if (pos_before >= data->last_start_min)
1273 b = data->last_start_min;
1276 s = SvPV(data->last_found, l);
1277 old = b - data->last_start_min;
1280 I32 b = pos_before >= data->last_start_min
1281 ? pos_before : data->last_start_min;
1283 char *s = SvPV(data->last_found, l);
1284 I32 old = b - data->last_start_min;
1288 old = utf8_hop((U8*)s, old) - (U8*)s;
1291 /* Get the added string: */
1292 last_str = newSVpvn(s + old, l);
1293 if (deltanext == 0 && pos_before == b) {
1294 /* What was added is a constant string */
1296 SvGROW(last_str, (mincount * l) + 1);
1297 repeatcpy(SvPVX(last_str) + l,
1298 SvPVX(last_str), l, mincount - 1);
1299 SvCUR(last_str) *= mincount;
1300 /* Add additional parts. */
1301 SvCUR_set(data->last_found,
1302 SvCUR(data->last_found) - l);
1303 sv_catsv(data->last_found, last_str);
1304 data->last_end += l * (mincount - 1);
1307 /* start offset must point into the last copy */
1308 data->last_start_min += minnext * (mincount - 1);
1309 data->last_start_max += is_inf ? 0 : (maxcount - 1)
1310 * (minnext + data->pos_delta);
1313 /* It is counted once already... */
1314 data->pos_min += minnext * (mincount - counted);
1315 data->pos_delta += - counted * deltanext +
1316 (minnext + deltanext) * maxcount - minnext * mincount;
1317 if (mincount != maxcount) {
1318 /* Cannot extend fixed substrings found inside
1320 scan_commit(pRExC_state,data);
1321 if (mincount && last_str) {
1322 sv_setsv(data->last_found, last_str);
1323 data->last_end = data->pos_min;
1324 data->last_start_min =
1325 data->pos_min - CHR_SVLEN(last_str);
1326 data->last_start_max = is_inf
1328 : data->pos_min + data->pos_delta
1329 - CHR_SVLEN(last_str);
1331 data->longest = &(data->longest_float);
1333 SvREFCNT_dec(last_str);
1335 if (data && (fl & SF_HAS_EVAL))
1336 data->flags |= SF_HAS_EVAL;
1337 optimize_curly_tail:
1338 if (OP(oscan) != CURLYX) {
1339 while (PL_regkind[(U8)OP(next = regnext(oscan))] == NOTHING
1341 NEXT_OFF(oscan) += NEXT_OFF(next);
1344 default: /* REF and CLUMP only? */
1345 if (flags & SCF_DO_SUBSTR) {
1346 scan_commit(pRExC_state,data); /* Cannot expect anything... */
1347 data->longest = &(data->longest_float);
1349 is_inf = is_inf_internal = 1;
1350 if (flags & SCF_DO_STCLASS_OR)
1351 cl_anything(pRExC_state, data->start_class);
1352 flags &= ~SCF_DO_STCLASS;
1356 else if (strchr((char*)PL_simple,OP(scan))) {
1359 if (flags & SCF_DO_SUBSTR) {
1360 scan_commit(pRExC_state,data);
1364 if (flags & SCF_DO_STCLASS) {
1365 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
1367 /* Some of the logic below assumes that switching
1368 locale on will only add false positives. */
1369 switch (PL_regkind[(U8)OP(scan)]) {
1373 /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
1374 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
1375 cl_anything(pRExC_state, data->start_class);
1378 if (OP(scan) == SANY)
1380 if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
1381 value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
1382 || (data->start_class->flags & ANYOF_CLASS));
1383 cl_anything(pRExC_state, data->start_class);
1385 if (flags & SCF_DO_STCLASS_AND || !value)
1386 ANYOF_BITMAP_CLEAR(data->start_class,'\n');
1389 if (flags & SCF_DO_STCLASS_AND)
1390 cl_and(data->start_class,
1391 (struct regnode_charclass_class*)scan);
1393 cl_or(pRExC_state, data->start_class,
1394 (struct regnode_charclass_class*)scan);
1397 if (flags & SCF_DO_STCLASS_AND) {
1398 if (!(data->start_class->flags & ANYOF_LOCALE)) {
1399 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
1400 for (value = 0; value < 256; value++)
1401 if (!isALNUM(value))
1402 ANYOF_BITMAP_CLEAR(data->start_class, value);
1406 if (data->start_class->flags & ANYOF_LOCALE)
1407 ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
1409 for (value = 0; value < 256; value++)
1411 ANYOF_BITMAP_SET(data->start_class, value);
1416 if (flags & SCF_DO_STCLASS_AND) {
1417 if (data->start_class->flags & ANYOF_LOCALE)
1418 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
1421 ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
1422 data->start_class->flags |= ANYOF_LOCALE;
1426 if (flags & SCF_DO_STCLASS_AND) {
1427 if (!(data->start_class->flags & ANYOF_LOCALE)) {
1428 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
1429 for (value = 0; value < 256; value++)
1431 ANYOF_BITMAP_CLEAR(data->start_class, value);
1435 if (data->start_class->flags & ANYOF_LOCALE)
1436 ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
1438 for (value = 0; value < 256; value++)
1439 if (!isALNUM(value))
1440 ANYOF_BITMAP_SET(data->start_class, value);
1445 if (flags & SCF_DO_STCLASS_AND) {
1446 if (data->start_class->flags & ANYOF_LOCALE)
1447 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
1450 data->start_class->flags |= ANYOF_LOCALE;
1451 ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
1455 if (flags & SCF_DO_STCLASS_AND) {
1456 if (!(data->start_class->flags & ANYOF_LOCALE)) {
1457 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
1458 for (value = 0; value < 256; value++)
1459 if (!isSPACE(value))
1460 ANYOF_BITMAP_CLEAR(data->start_class, value);
1464 if (data->start_class->flags & ANYOF_LOCALE)
1465 ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
1467 for (value = 0; value < 256; value++)
1469 ANYOF_BITMAP_SET(data->start_class, value);
1474 if (flags & SCF_DO_STCLASS_AND) {
1475 if (data->start_class->flags & ANYOF_LOCALE)
1476 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
1479 data->start_class->flags |= ANYOF_LOCALE;
1480 ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
1484 if (flags & SCF_DO_STCLASS_AND) {
1485 if (!(data->start_class->flags & ANYOF_LOCALE)) {
1486 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
1487 for (value = 0; value < 256; value++)
1489 ANYOF_BITMAP_CLEAR(data->start_class, value);
1493 if (data->start_class->flags & ANYOF_LOCALE)
1494 ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
1496 for (value = 0; value < 256; value++)
1497 if (!isSPACE(value))
1498 ANYOF_BITMAP_SET(data->start_class, value);
1503 if (flags & SCF_DO_STCLASS_AND) {
1504 if (data->start_class->flags & ANYOF_LOCALE) {
1505 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
1506 for (value = 0; value < 256; value++)
1507 if (!isSPACE(value))
1508 ANYOF_BITMAP_CLEAR(data->start_class, value);
1512 data->start_class->flags |= ANYOF_LOCALE;
1513 ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
1517 if (flags & SCF_DO_STCLASS_AND) {
1518 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT);
1519 for (value = 0; value < 256; value++)
1520 if (!isDIGIT(value))
1521 ANYOF_BITMAP_CLEAR(data->start_class, value);
1524 if (data->start_class->flags & ANYOF_LOCALE)
1525 ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT);
1527 for (value = 0; value < 256; value++)
1529 ANYOF_BITMAP_SET(data->start_class, value);
1534 if (flags & SCF_DO_STCLASS_AND) {
1535 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT);
1536 for (value = 0; value < 256; value++)
1538 ANYOF_BITMAP_CLEAR(data->start_class, value);
1541 if (data->start_class->flags & ANYOF_LOCALE)
1542 ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT);
1544 for (value = 0; value < 256; value++)
1545 if (!isDIGIT(value))
1546 ANYOF_BITMAP_SET(data->start_class, value);
1551 if (flags & SCF_DO_STCLASS_OR)
1552 cl_and(data->start_class, &and_with);
1553 flags &= ~SCF_DO_STCLASS;
1556 else if (PL_regkind[(U8)OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
1557 data->flags |= (OP(scan) == MEOL
1561 else if ( PL_regkind[(U8)OP(scan)] == BRANCHJ
1562 /* Lookbehind, or need to calculate parens/evals/stclass: */
1563 && (scan->flags || data || (flags & SCF_DO_STCLASS))
1564 && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
1565 /* Lookahead/lookbehind */
1566 I32 deltanext, minnext, fake = 0;
1568 struct regnode_charclass_class intrnl;
1571 data_fake.flags = 0;
1573 data_fake.whilem_c = data->whilem_c;
1574 data_fake.last_closep = data->last_closep;
1577 data_fake.last_closep = &fake;
1578 if ( flags & SCF_DO_STCLASS && !scan->flags
1579 && OP(scan) == IFMATCH ) { /* Lookahead */
1580 cl_init(pRExC_state, &intrnl);
1581 data_fake.start_class = &intrnl;
1582 f |= SCF_DO_STCLASS_AND;
1584 if (flags & SCF_WHILEM_VISITED_POS)
1585 f |= SCF_WHILEM_VISITED_POS;
1586 next = regnext(scan);
1587 nscan = NEXTOPER(NEXTOPER(scan));
1588 minnext = study_chunk(pRExC_state, &nscan, &deltanext, last, &data_fake, f);
1591 vFAIL("Variable length lookbehind not implemented");
1593 else if (minnext > U8_MAX) {
1594 vFAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
1596 scan->flags = minnext;
1598 if (data && data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
1600 if (data && (data_fake.flags & SF_HAS_EVAL))
1601 data->flags |= SF_HAS_EVAL;
1603 data->whilem_c = data_fake.whilem_c;
1604 if (f & SCF_DO_STCLASS_AND) {
1605 int was = (data->start_class->flags & ANYOF_EOS);
1607 cl_and(data->start_class, &intrnl);
1609 data->start_class->flags |= ANYOF_EOS;
1612 else if (OP(scan) == OPEN) {
1615 else if (OP(scan) == CLOSE) {
1616 if (ARG(scan) == is_par) {
1617 next = regnext(scan);
1619 if ( next && (OP(next) != WHILEM) && next < last)
1620 is_par = 0; /* Disable optimization */
1623 *(data->last_closep) = ARG(scan);
1625 else if (OP(scan) == EVAL) {
1627 data->flags |= SF_HAS_EVAL;
1629 else if (OP(scan) == LOGICAL && scan->flags == 2) { /* Embedded follows */
1630 if (flags & SCF_DO_SUBSTR) {
1631 scan_commit(pRExC_state,data);
1632 data->longest = &(data->longest_float);
1634 is_inf = is_inf_internal = 1;
1635 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
1636 cl_anything(pRExC_state, data->start_class);
1637 flags &= ~SCF_DO_STCLASS;
1639 /* Else: zero-length, ignore. */
1640 scan = regnext(scan);
1645 *deltap = is_inf_internal ? I32_MAX : delta;
1646 if (flags & SCF_DO_SUBSTR && is_inf)
1647 data->pos_delta = I32_MAX - data->pos_min;
1648 if (is_par > U8_MAX)
1650 if (is_par && pars==1 && data) {
1651 data->flags |= SF_IN_PAR;
1652 data->flags &= ~SF_HAS_PAR;
1654 else if (pars && data) {
1655 data->flags |= SF_HAS_PAR;
1656 data->flags &= ~SF_IN_PAR;
1658 if (flags & SCF_DO_STCLASS_OR)
1659 cl_and(data->start_class, &and_with);
1664 S_add_data(pTHX_ RExC_state_t *pRExC_state, I32 n, char *s)
1666 if (RExC_rx->data) {
1667 Renewc(RExC_rx->data,
1668 sizeof(*RExC_rx->data) + sizeof(void*) * (RExC_rx->data->count + n - 1),
1669 char, struct reg_data);
1670 Renew(RExC_rx->data->what, RExC_rx->data->count + n, U8);
1671 RExC_rx->data->count += n;
1674 Newc(1207, RExC_rx->data, sizeof(*RExC_rx->data) + sizeof(void*) * (n - 1),
1675 char, struct reg_data);
1676 New(1208, RExC_rx->data->what, n, U8);
1677 RExC_rx->data->count = n;
1679 Copy(s, RExC_rx->data->what + RExC_rx->data->count - n, n, U8);
1680 return RExC_rx->data->count - n;
1684 Perl_reginitcolors(pTHX)
1687 char *s = PerlEnv_getenv("PERL_RE_COLORS");
1690 PL_colors[0] = s = savepv(s);
1692 s = strchr(s, '\t');
1698 PL_colors[i] = s = "";
1702 PL_colors[i++] = "";
1709 - pregcomp - compile a regular expression into internal code
1711 * We can't allocate space until we know how big the compiled form will be,
1712 * but we can't compile it (and thus know how big it is) until we've got a
1713 * place to put the code. So we cheat: we compile it twice, once with code
1714 * generation turned off and size counting turned on, and once "for real".
1715 * This also means that we don't allocate space until we are sure that the
1716 * thing really will compile successfully, and we never have to move the
1717 * code and thus invalidate pointers into it. (Note that it has to be in
1718 * one piece because free() must be able to free it all.) [NB: not true in perl]
1720 * Beware that the optimization-preparation code in here knows about some
1721 * of the structure of the compiled regexp. [I'll say.]
1724 Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
1734 RExC_state_t RExC_state;
1735 RExC_state_t *pRExC_state = &RExC_state;
1738 FAIL("NULL regexp argument");
1740 RExC_utf8 = pm->op_pmdynflags & PMdf_CMP_UTF8;
1744 if (!PL_colorset) reginitcolors();
1745 PerlIO_printf(Perl_debug_log, "%sCompiling REx%s `%s%*s%s'\n",
1746 PL_colors[4],PL_colors[5],PL_colors[0],
1747 (int)(xend - exp), RExC_precomp, PL_colors[1]);
1749 RExC_flags16 = pm->op_pmflags;
1753 RExC_seen_zerolen = *exp == '^' ? -1 : 0;
1754 RExC_seen_evals = 0;
1757 /* First pass: determine size, legality. */
1764 RExC_emit = &PL_regdummy;
1765 RExC_whilem_seen = 0;
1766 #if 0 /* REGC() is (currently) a NOP at the first pass.
1767 * Clever compilers notice this and complain. --jhi */
1768 REGC((U8)REG_MAGIC, (char*)RExC_emit);
1770 if (reg(pRExC_state, 0, &flags) == NULL) {
1771 RExC_precomp = Nullch;
1774 DEBUG_r(PerlIO_printf(Perl_debug_log, "size %"IVdf" ", (IV)RExC_size));
1776 /* Small enough for pointer-storage convention?
1777 If extralen==0, this means that we will not need long jumps. */
1778 if (RExC_size >= 0x10000L && RExC_extralen)
1779 RExC_size += RExC_extralen;
1782 if (RExC_whilem_seen > 15)
1783 RExC_whilem_seen = 15;
1785 /* Allocate space and initialize. */
1786 Newc(1001, r, sizeof(regexp) + (unsigned)RExC_size * sizeof(regnode),
1789 FAIL("Regexp out of space");
1792 /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
1793 Zero(r, sizeof(regexp) + (unsigned)RExC_size * sizeof(regnode), char);
1796 r->prelen = xend - exp;
1797 r->precomp = savepvn(RExC_precomp, r->prelen);
1799 r->reganch = pm->op_pmflags & PMf_COMPILETIME;
1800 r->nparens = RExC_npar - 1; /* set early to validate backrefs */
1802 r->substrs = 0; /* Useful during FAIL. */
1803 r->startp = 0; /* Useful during FAIL. */
1804 r->endp = 0; /* Useful during FAIL. */
1806 Newz(1304, r->offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
1808 r->offsets[0] = RExC_size;
1810 DEBUG_r(PerlIO_printf(Perl_debug_log,
1811 "%s %"UVuf" bytes for offset annotations.\n",
1812 r->offsets ? "Got" : "Couldn't get",
1813 (UV)((2*RExC_size+1) * sizeof(U32))));
1817 /* Second pass: emit code. */
1818 RExC_flags16 = pm->op_pmflags; /* don't let top level (?i) bleed */
1823 RExC_emit_start = r->program;
1824 RExC_emit = r->program;
1825 /* Store the count of eval-groups for security checks: */
1826 RExC_emit->next_off = ((RExC_seen_evals > U16_MAX) ? U16_MAX : RExC_seen_evals);
1827 REGC((U8)REG_MAGIC, (char*) RExC_emit++);
1829 if (reg(pRExC_state, 0, &flags) == NULL)
1832 /* Dig out information for optimizations. */
1833 r->reganch = pm->op_pmflags & PMf_COMPILETIME; /* Again? */
1834 pm->op_pmflags = RExC_flags16;
1836 r->reganch |= ROPT_UTF8; /* Unicode in it? */
1837 r->regstclass = NULL;
1838 if (RExC_naughty >= 10) /* Probably an expensive pattern. */
1839 r->reganch |= ROPT_NAUGHTY;
1840 scan = r->program + 1; /* First BRANCH. */
1842 /* XXXX To minimize changes to RE engine we always allocate
1843 3-units-long substrs field. */
1844 Newz(1004, r->substrs, 1, struct reg_substr_data);
1846 StructCopy(&zero_scan_data, &data, scan_data_t);
1847 /* XXXX Should not we check for something else? Usually it is OPEN1... */
1848 if (OP(scan) != BRANCH) { /* Only one top-level choice. */
1850 STRLEN longest_float_length, longest_fixed_length;
1851 struct regnode_charclass_class ch_class;
1856 /* Skip introductions and multiplicators >= 1. */
1857 while ((OP(first) == OPEN && (sawopen = 1)) ||
1858 /* An OR of *one* alternative - should not happen now. */
1859 (OP(first) == BRANCH && OP(regnext(first)) != BRANCH) ||
1860 (OP(first) == PLUS) ||
1861 (OP(first) == MINMOD) ||
1862 /* An {n,m} with n>0 */
1863 (PL_regkind[(U8)OP(first)] == CURLY && ARG1(first) > 0) ) {
1864 if (OP(first) == PLUS)
1867 first += regarglen[(U8)OP(first)];
1868 first = NEXTOPER(first);
1871 /* Starting-point info. */
1873 if (PL_regkind[(U8)OP(first)] == EXACT) {
1874 if (OP(first) == EXACT)
1875 ; /* Empty, get anchored substr later. */
1876 else if ((OP(first) == EXACTF || OP(first) == EXACTFL))
1877 r->regstclass = first;
1879 else if (strchr((char*)PL_simple,OP(first)))
1880 r->regstclass = first;
1881 else if (PL_regkind[(U8)OP(first)] == BOUND ||
1882 PL_regkind[(U8)OP(first)] == NBOUND)
1883 r->regstclass = first;
1884 else if (PL_regkind[(U8)OP(first)] == BOL) {
1885 r->reganch |= (OP(first) == MBOL
1887 : (OP(first) == SBOL
1890 first = NEXTOPER(first);
1893 else if (OP(first) == GPOS) {
1894 r->reganch |= ROPT_ANCH_GPOS;
1895 first = NEXTOPER(first);
1898 else if (!sawopen && (OP(first) == STAR &&
1899 PL_regkind[(U8)OP(NEXTOPER(first))] == REG_ANY) &&
1900 !(r->reganch & ROPT_ANCH) )
1902 /* turn .* into ^.* with an implied $*=1 */
1903 int type = OP(NEXTOPER(first));
1905 if (type == REG_ANY)
1906 type = ROPT_ANCH_MBOL;
1908 type = ROPT_ANCH_SBOL;
1910 r->reganch |= type | ROPT_IMPLICIT;
1911 first = NEXTOPER(first);
1914 if (sawplus && (!sawopen || !RExC_sawback)
1915 && !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */
1916 /* x+ must match at the 1st pos of run of x's */
1917 r->reganch |= ROPT_SKIP;
1919 /* Scan is after the zeroth branch, first is atomic matcher. */
1920 DEBUG_r(PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
1921 (IV)(first - scan + 1)));
1923 * If there's something expensive in the r.e., find the
1924 * longest literal string that must appear and make it the
1925 * regmust. Resolve ties in favor of later strings, since
1926 * the regstart check works with the beginning of the r.e.
1927 * and avoiding duplication strengthens checking. Not a
1928 * strong reason, but sufficient in the absence of others.
1929 * [Now we resolve ties in favor of the earlier string if
1930 * it happens that c_offset_min has been invalidated, since the
1931 * earlier string may buy us something the later one won't.]
1935 data.longest_fixed = newSVpvn("",0);
1936 data.longest_float = newSVpvn("",0);
1937 data.last_found = newSVpvn("",0);
1938 data.longest = &(data.longest_fixed);
1940 if (!r->regstclass) {
1941 cl_init(pRExC_state, &ch_class);
1942 data.start_class = &ch_class;
1943 stclass_flag = SCF_DO_STCLASS_AND;
1944 } else /* XXXX Check for BOUND? */
1946 data.last_closep = &last_close;
1948 minlen = study_chunk(pRExC_state, &first, &fake, scan + RExC_size, /* Up to end */
1949 &data, SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag);
1950 if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
1951 && data.last_start_min == 0 && data.last_end > 0
1952 && !RExC_seen_zerolen
1953 && (!(RExC_seen & REG_SEEN_GPOS) || (r->reganch & ROPT_ANCH_GPOS)))
1954 r->reganch |= ROPT_CHECK_ALL;
1955 scan_commit(pRExC_state, &data);
1956 SvREFCNT_dec(data.last_found);
1958 longest_float_length = CHR_SVLEN(data.longest_float);
1959 if (longest_float_length
1960 || (data.flags & SF_FL_BEFORE_EOL
1961 && (!(data.flags & SF_FL_BEFORE_MEOL)
1962 || (RExC_flags16 & PMf_MULTILINE)))) {
1965 if (SvCUR(data.longest_fixed) /* ok to leave SvCUR */
1966 && data.offset_fixed == data.offset_float_min
1967 && SvCUR(data.longest_fixed) == SvCUR(data.longest_float))
1968 goto remove_float; /* As in (a)+. */
1970 if (SvUTF8(data.longest_float)) {
1971 r->float_utf8 = data.longest_float;
1972 r->float_substr = Nullsv;
1974 r->float_substr = data.longest_float;
1975 r->float_utf8 = Nullsv;
1977 r->float_min_offset = data.offset_float_min;
1978 r->float_max_offset = data.offset_float_max;
1979 t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
1980 && (!(data.flags & SF_FL_BEFORE_MEOL)
1981 || (RExC_flags16 & PMf_MULTILINE)));
1982 fbm_compile(data.longest_float, t ? FBMcf_TAIL : 0);
1986 r->float_substr = r->float_utf8 = Nullsv;
1987 SvREFCNT_dec(data.longest_float);
1988 longest_float_length = 0;
1991 longest_fixed_length = CHR_SVLEN(data.longest_fixed);
1992 if (longest_fixed_length
1993 || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
1994 && (!(data.flags & SF_FIX_BEFORE_MEOL)
1995 || (RExC_flags16 & PMf_MULTILINE)))) {
1998 if (SvUTF8(data.longest_fixed)) {
1999 r->anchored_utf8 = data.longest_fixed;
2000 r->anchored_substr = Nullsv;
2002 r->anchored_substr = data.longest_fixed;
2003 r->anchored_utf8 = Nullsv;
2005 r->anchored_offset = data.offset_fixed;
2006 t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
2007 && (!(data.flags & SF_FIX_BEFORE_MEOL)
2008 || (RExC_flags16 & PMf_MULTILINE)));
2009 fbm_compile(data.longest_fixed, t ? FBMcf_TAIL : 0);
2012 r->anchored_substr = r->anchored_utf8 = Nullsv;
2013 SvREFCNT_dec(data.longest_fixed);
2014 longest_fixed_length = 0;
2017 && (OP(r->regstclass) == REG_ANY || OP(r->regstclass) == SANY))
2018 r->regstclass = NULL;
2019 if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
2021 && !(data.start_class->flags & ANYOF_EOS)
2022 && !cl_is_anything(data.start_class)) {
2023 I32 n = add_data(pRExC_state, 1, "f");
2025 New(1006, RExC_rx->data->data[n], 1,
2026 struct regnode_charclass_class);
2027 StructCopy(data.start_class,
2028 (struct regnode_charclass_class*)RExC_rx->data->data[n],
2029 struct regnode_charclass_class);
2030 r->regstclass = (regnode*)RExC_rx->data->data[n];
2031 r->reganch &= ~ROPT_SKIP; /* Used in find_byclass(). */
2032 PL_regdata = r->data; /* for regprop() */
2033 DEBUG_r({ SV *sv = sv_newmortal();
2034 regprop(sv, (regnode*)data.start_class);
2035 PerlIO_printf(Perl_debug_log,
2036 "synthetic stclass `%s'.\n",
2040 /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
2041 if (longest_fixed_length > longest_float_length) {
2042 r->check_substr = r->anchored_substr;
2043 r->check_utf8 = r->anchored_utf8;
2044 r->check_offset_min = r->check_offset_max = r->anchored_offset;
2045 if (r->reganch & ROPT_ANCH_SINGLE)
2046 r->reganch |= ROPT_NOSCAN;
2049 r->check_substr = r->float_substr;
2050 r->check_utf8 = r->float_utf8;
2051 r->check_offset_min = data.offset_float_min;
2052 r->check_offset_max = data.offset_float_max;
2054 /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
2055 This should be changed ASAP! */
2056 if ((r->check_substr || r->check_utf8) && !(r->reganch & ROPT_ANCH_GPOS)) {
2057 r->reganch |= RE_USE_INTUIT;
2058 if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
2059 r->reganch |= RE_INTUIT_TAIL;
2063 /* Several toplevels. Best we can is to set minlen. */
2065 struct regnode_charclass_class ch_class;
2068 DEBUG_r(PerlIO_printf(Perl_debug_log, "\n"));
2069 scan = r->program + 1;
2070 cl_init(pRExC_state, &ch_class);
2071 data.start_class = &ch_class;
2072 data.last_closep = &last_close;
2073 minlen = study_chunk(pRExC_state, &scan, &fake, scan + RExC_size, &data, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS);
2074 r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
2075 = r->float_substr = r->float_utf8 = Nullsv;
2076 if (!(data.start_class->flags & ANYOF_EOS)
2077 && !cl_is_anything(data.start_class)) {
2078 I32 n = add_data(pRExC_state, 1, "f");
2080 New(1006, RExC_rx->data->data[n], 1,
2081 struct regnode_charclass_class);
2082 StructCopy(data.start_class,
2083 (struct regnode_charclass_class*)RExC_rx->data->data[n],
2084 struct regnode_charclass_class);
2085 r->regstclass = (regnode*)RExC_rx->data->data[n];
2086 r->reganch &= ~ROPT_SKIP; /* Used in find_byclass(). */
2087 DEBUG_r({ SV* sv = sv_newmortal();
2088 regprop(sv, (regnode*)data.start_class);
2089 PerlIO_printf(Perl_debug_log,
2090 "synthetic stclass `%s'.\n",
2096 if (RExC_seen & REG_SEEN_GPOS)
2097 r->reganch |= ROPT_GPOS_SEEN;
2098 if (RExC_seen & REG_SEEN_LOOKBEHIND)
2099 r->reganch |= ROPT_LOOKBEHIND_SEEN;
2100 if (RExC_seen & REG_SEEN_EVAL)
2101 r->reganch |= ROPT_EVAL_SEEN;
2102 if (RExC_seen & REG_SEEN_CANY)
2103 r->reganch |= ROPT_CANY_SEEN;
2104 Newz(1002, r->startp, RExC_npar, I32);
2105 Newz(1002, r->endp, RExC_npar, I32);
2106 PL_regdata = r->data; /* for regprop() */
2107 DEBUG_r(regdump(r));
2112 - reg - regular expression, i.e. main body or parenthesized thing
2114 * Caller must absorb opening parenthesis.
2116 * Combining parenthesis handling with the base level of regular expression
2117 * is a trifle forced, but the need to tie the tails of the branches to what
2118 * follows makes it hard to avoid.
2121 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp)
2122 /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
2124 register regnode *ret; /* Will be the head of the group. */
2125 register regnode *br;
2126 register regnode *lastbr;
2127 register regnode *ender = 0;
2128 register I32 parno = 0;
2129 I32 flags, oregflags = RExC_flags16, have_branch = 0, open = 0;
2131 /* for (?g), (?gc), and (?o) warnings; warning
2132 about (?c) will warn about (?g) -- japhy */
2134 I32 wastedflags = 0x00,
2137 wasted_gc = 0x02 | 0x04,
2140 char * parse_start = RExC_parse; /* MJD */
2141 char *oregcomp_parse = RExC_parse;
2144 *flagp = 0; /* Tentatively. */
2147 /* Make an OPEN node, if parenthesized. */
2149 if (*RExC_parse == '?') { /* (?...) */
2150 U16 posflags = 0, negflags = 0;
2151 U16 *flagsp = &posflags;
2153 char *seqstart = RExC_parse;
2156 paren = *RExC_parse++;
2157 ret = NULL; /* For look-ahead/behind. */
2159 case '<': /* (?<...) */
2160 RExC_seen |= REG_SEEN_LOOKBEHIND;
2161 if (*RExC_parse == '!')
2163 if (*RExC_parse != '=' && *RExC_parse != '!')
2166 case '=': /* (?=...) */
2167 case '!': /* (?!...) */
2168 RExC_seen_zerolen++;
2169 case ':': /* (?:...) */
2170 case '>': /* (?>...) */
2172 case '$': /* (?$...) */
2173 case '@': /* (?@...) */
2174 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
2176 case '#': /* (?#...) */
2177 while (*RExC_parse && *RExC_parse != ')')
2179 if (*RExC_parse != ')')
2180 FAIL("Sequence (?#... not terminated");
2181 nextchar(pRExC_state);
2184 case 'p': /* (?p...) */
2185 if (SIZE_ONLY && ckWARN2(WARN_DEPRECATED, WARN_REGEXP))
2186 vWARNdep(RExC_parse, "(?p{}) is deprecated - use (??{})");
2188 case '?': /* (??...) */
2190 if (*RExC_parse != '{')
2192 paren = *RExC_parse++;
2194 case '{': /* (?{...}) */
2196 I32 count = 1, n = 0;
2198 char *s = RExC_parse;
2200 OP_4tree *sop, *rop;
2202 RExC_seen_zerolen++;
2203 RExC_seen |= REG_SEEN_EVAL;
2204 while (count && (c = *RExC_parse)) {
2205 if (c == '\\' && RExC_parse[1])
2213 if (*RExC_parse != ')')
2216 vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
2221 if (RExC_parse - 1 - s)
2222 sv = newSVpvn(s, RExC_parse - 1 - s);
2224 sv = newSVpvn("", 0);
2227 Perl_save_re_context(aTHX);
2228 rop = sv_compile_2op(sv, &sop, "re", &av);
2229 sop->op_private |= OPpREFCOUNTED;
2230 /* re_dup will OpREFCNT_inc */
2231 OpREFCNT_set(sop, 1);
2234 n = add_data(pRExC_state, 3, "nop");
2235 RExC_rx->data->data[n] = (void*)rop;
2236 RExC_rx->data->data[n+1] = (void*)sop;
2237 RExC_rx->data->data[n+2] = (void*)av;
2240 else { /* First pass */
2241 if (PL_reginterp_cnt < ++RExC_seen_evals
2242 && PL_curcop != &PL_compiling)
2243 /* No compiled RE interpolated, has runtime
2244 components ===> unsafe. */
2245 FAIL("Eval-group not allowed at runtime, use re 'eval'");
2246 if (PL_tainting && PL_tainted)
2247 FAIL("Eval-group in insecure regular expression");
2250 nextchar(pRExC_state);
2252 ret = reg_node(pRExC_state, LOGICAL);
2255 regtail(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
2256 /* deal with the length of this later - MJD */
2259 return reganode(pRExC_state, EVAL, n);
2261 case '(': /* (?(?{...})...) and (?(?=...)...) */
2263 if (RExC_parse[0] == '?') { /* (?(?...)) */
2264 if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
2265 || RExC_parse[1] == '<'
2266 || RExC_parse[1] == '{') { /* Lookahead or eval. */
2269 ret = reg_node(pRExC_state, LOGICAL);
2272 regtail(pRExC_state, ret, reg(pRExC_state, 1, &flag));
2276 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
2278 parno = atoi(RExC_parse++);
2280 while (isDIGIT(*RExC_parse))
2282 ret = reganode(pRExC_state, GROUPP, parno);
2284 if ((c = *nextchar(pRExC_state)) != ')')
2285 vFAIL("Switch condition not recognized");
2287 regtail(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
2288 br = regbranch(pRExC_state, &flags, 1);
2290 br = reganode(pRExC_state, LONGJMP, 0);
2292 regtail(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
2293 c = *nextchar(pRExC_state);
2297 lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
2298 regbranch(pRExC_state, &flags, 1);
2299 regtail(pRExC_state, ret, lastbr);
2302 c = *nextchar(pRExC_state);
2307 vFAIL("Switch (?(condition)... contains too many branches");
2308 ender = reg_node(pRExC_state, TAIL);
2309 regtail(pRExC_state, br, ender);
2311 regtail(pRExC_state, lastbr, ender);
2312 regtail(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
2315 regtail(pRExC_state, ret, ender);
2319 vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
2323 RExC_parse--; /* for vFAIL to print correctly */
2324 vFAIL("Sequence (? incomplete");
2328 parse_flags: /* (?i) */
2329 while (*RExC_parse && strchr("iogcmsx", *RExC_parse)) {
2330 /* (?g), (?gc) and (?o) are useless here
2331 and must be globally applied -- japhy */
2333 if (*RExC_parse == 'o' || *RExC_parse == 'g') {
2334 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
2335 I32 wflagbit = *RExC_parse == 'o' ? wasted_o : wasted_g;
2336 if (! (wastedflags & wflagbit) ) {
2337 wastedflags |= wflagbit;
2340 "Useless (%s%c) - %suse /%c modifier",
2341 flagsp == &negflags ? "?-" : "?",
2343 flagsp == &negflags ? "don't " : "",
2349 else if (*RExC_parse == 'c') {
2350 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
2351 if (! (wastedflags & wasted_c) ) {
2352 wastedflags |= wasted_gc;
2355 "Useless (%sc) - %suse /gc modifier",
2356 flagsp == &negflags ? "?-" : "?",
2357 flagsp == &negflags ? "don't " : ""
2362 else { pmflag(flagsp, *RExC_parse); }
2366 if (*RExC_parse == '-') {
2368 wastedflags = 0; /* reset so (?g-c) warns twice */
2372 RExC_flags16 |= posflags;
2373 RExC_flags16 &= ~negflags;
2374 if (*RExC_parse == ':') {
2380 if (*RExC_parse != ')') {
2382 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
2384 nextchar(pRExC_state);
2392 ret = reganode(pRExC_state, OPEN, parno);
2393 Set_Node_Length(ret, 1); /* MJD */
2394 Set_Node_Offset(ret, RExC_parse); /* MJD */
2401 /* Pick up the branches, linking them together. */
2402 parse_start = RExC_parse; /* MJD */
2403 br = regbranch(pRExC_state, &flags, 1);
2404 /* branch_len = (paren != 0); */
2408 if (*RExC_parse == '|') {
2409 if (!SIZE_ONLY && RExC_extralen) {
2410 reginsert(pRExC_state, BRANCHJ, br);
2413 reginsert(pRExC_state, BRANCH, br);
2414 Set_Node_Length(br, paren != 0);
2415 Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
2419 RExC_extralen += 1; /* For BRANCHJ-BRANCH. */
2421 else if (paren == ':') {
2422 *flagp |= flags&SIMPLE;
2424 if (open) { /* Starts with OPEN. */
2425 regtail(pRExC_state, ret, br); /* OPEN -> first. */
2427 else if (paren != '?') /* Not Conditional */
2429 *flagp |= flags & (SPSTART | HASWIDTH);
2431 while (*RExC_parse == '|') {
2432 if (!SIZE_ONLY && RExC_extralen) {
2433 ender = reganode(pRExC_state, LONGJMP,0);
2434 regtail(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
2437 RExC_extralen += 2; /* Account for LONGJMP. */
2438 nextchar(pRExC_state);
2439 br = regbranch(pRExC_state, &flags, 0);
2443 regtail(pRExC_state, lastbr, br); /* BRANCH -> BRANCH. */
2447 *flagp |= flags&SPSTART;
2450 if (have_branch || paren != ':') {
2451 /* Make a closing node, and hook it on the end. */
2454 ender = reg_node(pRExC_state, TAIL);
2457 ender = reganode(pRExC_state, CLOSE, parno);
2458 Set_Node_Offset(ender,RExC_parse+1); /* MJD */
2459 Set_Node_Length(ender,1); /* MJD */
2465 *flagp &= ~HASWIDTH;
2468 ender = reg_node(pRExC_state, SUCCEED);
2471 ender = reg_node(pRExC_state, END);
2474 regtail(pRExC_state, lastbr, ender);
2477 /* Hook the tails of the branches to the closing node. */
2478 for (br = ret; br != NULL; br = regnext(br)) {
2479 regoptail(pRExC_state, br, ender);
2486 static char parens[] = "=!<,>";
2488 if (paren && (p = strchr(parens, paren))) {
2489 int node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
2490 int flag = (p - parens) > 1;
2493 node = SUSPEND, flag = 0;
2494 reginsert(pRExC_state, node,ret);
2496 regtail(pRExC_state, ret, reg_node(pRExC_state, TAIL));
2500 /* Check for proper termination. */
2502 RExC_flags16 = oregflags;
2503 if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
2504 RExC_parse = oregcomp_parse;
2505 vFAIL("Unmatched (");
2508 else if (!paren && RExC_parse < RExC_end) {
2509 if (*RExC_parse == ')') {
2511 vFAIL("Unmatched )");
2514 FAIL("Junk on end of regexp"); /* "Can't happen". */
2522 - regbranch - one alternative of an | operator
2524 * Implements the concatenation operator.
2527 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first)
2529 register regnode *ret;
2530 register regnode *chain = NULL;
2531 register regnode *latest;
2532 I32 flags = 0, c = 0;
2537 if (!SIZE_ONLY && RExC_extralen)
2538 ret = reganode(pRExC_state, BRANCHJ,0);
2540 ret = reg_node(pRExC_state, BRANCH);
2541 Set_Node_Length(ret, 1);
2545 if (!first && SIZE_ONLY)
2546 RExC_extralen += 1; /* BRANCHJ */
2548 *flagp = WORST; /* Tentatively. */
2551 nextchar(pRExC_state);
2552 while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
2554 latest = regpiece(pRExC_state, &flags);
2555 if (latest == NULL) {
2556 if (flags & TRYAGAIN)
2560 else if (ret == NULL)
2562 *flagp |= flags&HASWIDTH;
2563 if (chain == NULL) /* First piece. */
2564 *flagp |= flags&SPSTART;
2567 regtail(pRExC_state, chain, latest);
2572 if (chain == NULL) { /* Loop ran zero times. */
2573 chain = reg_node(pRExC_state, NOTHING);
2578 *flagp |= flags&SIMPLE;
2585 - regpiece - something followed by possible [*+?]
2587 * Note that the branching code sequences used for ? and the general cases
2588 * of * and + are somewhat optimized: they use the same NOTHING node as
2589 * both the endmarker for their branch list and the body of the last branch.
2590 * It might seem that this node could be dispensed with entirely, but the
2591 * endmarker role is not redundant.
2594 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp)
2596 register regnode *ret;
2598 register char *next;
2600 char *origparse = RExC_parse;
2603 I32 max = REG_INFTY;
2606 ret = regatom(pRExC_state, &flags);
2608 if (flags & TRYAGAIN)
2615 if (op == '{' && regcurly(RExC_parse)) {
2616 parse_start = RExC_parse; /* MJD */
2617 next = RExC_parse + 1;
2619 while (isDIGIT(*next) || *next == ',') {
2628 if (*next == '}') { /* got one */
2632 min = atoi(RExC_parse);
2636 maxpos = RExC_parse;
2638 if (!max && *maxpos != '0')
2639 max = REG_INFTY; /* meaning "infinity" */
2640 else if (max >= REG_INFTY)
2641 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
2643 nextchar(pRExC_state);
2646 if ((flags&SIMPLE)) {
2647 RExC_naughty += 2 + RExC_naughty / 2;
2648 reginsert(pRExC_state, CURLY, ret);
2649 Set_Node_Offset(ret, parse_start+1); /* MJD */
2650 Set_Node_Cur_Length(ret);
2653 regnode *w = reg_node(pRExC_state, WHILEM);
2656 regtail(pRExC_state, ret, w);
2657 if (!SIZE_ONLY && RExC_extralen) {
2658 reginsert(pRExC_state, LONGJMP,ret);
2659 reginsert(pRExC_state, NOTHING,ret);
2660 NEXT_OFF(ret) = 3; /* Go over LONGJMP. */
2662 reginsert(pRExC_state, CURLYX,ret);
2664 Set_Node_Offset(ret, parse_start+1);
2665 Set_Node_Length(ret,
2666 op == '{' ? (RExC_parse - parse_start) : 1);
2668 if (!SIZE_ONLY && RExC_extralen)
2669 NEXT_OFF(ret) = 3; /* Go over NOTHING to LONGJMP. */
2670 regtail(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
2672 RExC_whilem_seen++, RExC_extralen += 3;
2673 RExC_naughty += 4 + RExC_naughty; /* compound interest */
2681 if (max && max < min)
2682 vFAIL("Can't do {n,m} with n > m");
2697 #if 0 /* Now runtime fix should be reliable. */
2699 /* if this is reinstated, don't forget to put this back into perldiag:
2701 =item Regexp *+ operand could be empty at {#} in regex m/%s/
2703 (F) The part of the regexp subject to either the * or + quantifier
2704 could match an empty string. The {#} shows in the regular
2705 expression about where the problem was discovered.
2709 if (!(flags&HASWIDTH) && op != '?')
2710 vFAIL("Regexp *+ operand could be empty");
2713 parse_start = RExC_parse;
2714 nextchar(pRExC_state);
2716 *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
2718 if (op == '*' && (flags&SIMPLE)) {
2719 reginsert(pRExC_state, STAR, ret);
2723 else if (op == '*') {
2727 else if (op == '+' && (flags&SIMPLE)) {
2728 reginsert(pRExC_state, PLUS, ret);
2732 else if (op == '+') {
2736 else if (op == '?') {
2741 if (ckWARN(WARN_REGEXP) && !SIZE_ONLY && !(flags&HASWIDTH) && max > REG_INFTY/3) {
2743 "%.*s matches null string many times",
2744 RExC_parse - origparse,
2748 if (*RExC_parse == '?') {
2749 nextchar(pRExC_state);
2750 reginsert(pRExC_state, MINMOD, ret);
2751 regtail(pRExC_state, ret, ret + NODE_STEP_REGNODE);
2753 if (ISMULT2(RExC_parse)) {
2755 vFAIL("Nested quantifiers");
2762 - regatom - the lowest level
2764 * Optimization: gobbles an entire sequence of ordinary characters so that
2765 * it can turn them into a single node, which is smaller to store and
2766 * faster to run. Backslashed characters are exceptions, each becoming a
2767 * separate node; the code is simpler that way and it's not worth fixing.
2769 * [Yes, it is worth fixing, some scripts can run twice the speed.] */
2771 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp)
2773 register regnode *ret = 0;
2775 char *parse_start = 0;
2777 *flagp = WORST; /* Tentatively. */
2780 switch (*RExC_parse) {
2782 RExC_seen_zerolen++;
2783 nextchar(pRExC_state);
2784 if (RExC_flags16 & PMf_MULTILINE)
2785 ret = reg_node(pRExC_state, MBOL);
2786 else if (RExC_flags16 & PMf_SINGLELINE)
2787 ret = reg_node(pRExC_state, SBOL);
2789 ret = reg_node(pRExC_state, BOL);
2790 Set_Node_Length(ret, 1); /* MJD */
2793 nextchar(pRExC_state);
2795 RExC_seen_zerolen++;
2796 if (RExC_flags16 & PMf_MULTILINE)
2797 ret = reg_node(pRExC_state, MEOL);
2798 else if (RExC_flags16 & PMf_SINGLELINE)
2799 ret = reg_node(pRExC_state, SEOL);
2801 ret = reg_node(pRExC_state, EOL);
2802 Set_Node_Length(ret, 1); /* MJD */
2805 nextchar(pRExC_state);
2806 if (RExC_flags16 & PMf_SINGLELINE)
2807 ret = reg_node(pRExC_state, SANY);
2809 ret = reg_node(pRExC_state, REG_ANY);
2810 *flagp |= HASWIDTH|SIMPLE;
2812 Set_Node_Length(ret, 1); /* MJD */
2816 char *oregcomp_parse = ++RExC_parse;
2817 ret = regclass(pRExC_state);
2818 if (*RExC_parse != ']') {
2819 RExC_parse = oregcomp_parse;
2820 vFAIL("Unmatched [");
2822 nextchar(pRExC_state);
2823 *flagp |= HASWIDTH|SIMPLE;
2824 Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
2828 nextchar(pRExC_state);
2829 ret = reg(pRExC_state, 1, &flags);
2831 if (flags & TRYAGAIN) {
2832 if (RExC_parse == RExC_end) {
2833 /* Make parent create an empty node if needed. */
2841 *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE);
2845 if (flags & TRYAGAIN) {
2849 vFAIL("Internal urp");
2850 /* Supposed to be caught earlier. */
2853 if (!regcurly(RExC_parse)) {
2862 vFAIL("Quantifier follows nothing");
2865 switch (*++RExC_parse) {
2867 RExC_seen_zerolen++;
2868 ret = reg_node(pRExC_state, SBOL);
2870 nextchar(pRExC_state);
2871 Set_Node_Length(ret, 2); /* MJD */
2874 ret = reg_node(pRExC_state, GPOS);
2875 RExC_seen |= REG_SEEN_GPOS;
2877 nextchar(pRExC_state);
2878 Set_Node_Length(ret, 2); /* MJD */
2881 ret = reg_node(pRExC_state, SEOL);
2883 RExC_seen_zerolen++; /* Do not optimize RE away */
2884 nextchar(pRExC_state);
2887 ret = reg_node(pRExC_state, EOS);
2889 RExC_seen_zerolen++; /* Do not optimize RE away */
2890 nextchar(pRExC_state);
2891 Set_Node_Length(ret, 2); /* MJD */
2894 ret = reg_node(pRExC_state, CANY);
2895 RExC_seen |= REG_SEEN_CANY;
2896 *flagp |= HASWIDTH|SIMPLE;
2897 nextchar(pRExC_state);
2898 Set_Node_Length(ret, 2); /* MJD */
2901 ret = reg_node(pRExC_state, CLUMP);
2903 nextchar(pRExC_state);
2904 Set_Node_Length(ret, 2); /* MJD */
2907 ret = reg_node(pRExC_state, LOC ? ALNUML : ALNUM);
2908 *flagp |= HASWIDTH|SIMPLE;
2909 nextchar(pRExC_state);
2910 Set_Node_Length(ret, 2); /* MJD */
2913 ret = reg_node(pRExC_state, LOC ? NALNUML : NALNUM);
2914 *flagp |= HASWIDTH|SIMPLE;
2915 nextchar(pRExC_state);
2916 Set_Node_Length(ret, 2); /* MJD */
2919 RExC_seen_zerolen++;
2920 RExC_seen |= REG_SEEN_LOOKBEHIND;
2921 ret = reg_node(pRExC_state, LOC ? BOUNDL : BOUND);
2923 nextchar(pRExC_state);
2924 Set_Node_Length(ret, 2); /* MJD */
2927 RExC_seen_zerolen++;
2928 RExC_seen |= REG_SEEN_LOOKBEHIND;
2929 ret = reg_node(pRExC_state, LOC ? NBOUNDL : NBOUND);
2931 nextchar(pRExC_state);
2932 Set_Node_Length(ret, 2); /* MJD */
2935 ret = reg_node(pRExC_state, LOC ? SPACEL : SPACE);
2936 *flagp |= HASWIDTH|SIMPLE;
2937 nextchar(pRExC_state);
2938 Set_Node_Length(ret, 2); /* MJD */
2941 ret = reg_node(pRExC_state, LOC ? NSPACEL : NSPACE);
2942 *flagp |= HASWIDTH|SIMPLE;
2943 nextchar(pRExC_state);
2944 Set_Node_Length(ret, 2); /* MJD */
2947 ret = reg_node(pRExC_state, DIGIT);
2948 *flagp |= HASWIDTH|SIMPLE;
2949 nextchar(pRExC_state);
2950 Set_Node_Length(ret, 2); /* MJD */
2953 ret = reg_node(pRExC_state, NDIGIT);
2954 *flagp |= HASWIDTH|SIMPLE;
2955 nextchar(pRExC_state);
2956 Set_Node_Length(ret, 2); /* MJD */
2961 char* oldregxend = RExC_end;
2962 char* parse_start = RExC_parse;
2964 if (RExC_parse[1] == '{') {
2965 /* a lovely hack--pretend we saw [\pX] instead */
2966 RExC_end = strchr(RExC_parse, '}');
2968 U8 c = (U8)*RExC_parse;
2970 RExC_end = oldregxend;
2971 vFAIL2("Missing right brace on \\%c{}", c);
2976 RExC_end = RExC_parse + 2;
2977 if (RExC_end > oldregxend)
2978 RExC_end = oldregxend;
2982 ret = regclass(pRExC_state);
2984 RExC_end = oldregxend;
2986 Set_Node_Cur_Length(ret); /* MJD */
2987 nextchar(pRExC_state);
2988 *flagp |= HASWIDTH|SIMPLE;
3001 case '1': case '2': case '3': case '4':
3002 case '5': case '6': case '7': case '8': case '9':
3004 I32 num = atoi(RExC_parse);
3006 if (num > 9 && num >= RExC_npar)
3009 char * parse_start = RExC_parse - 1; /* MJD */
3010 while (isDIGIT(*RExC_parse))
3013 if (!SIZE_ONLY && num > RExC_rx->nparens)
3014 vFAIL("Reference to nonexistent group");
3016 ret = reganode(pRExC_state, FOLD
3017 ? (LOC ? REFFL : REFF)
3021 /* override incorrect value set in reganode MJD */
3022 Set_Node_Offset(ret, parse_start+1);
3023 Set_Node_Cur_Length(ret); /* MJD */
3025 nextchar(pRExC_state);
3030 if (RExC_parse >= RExC_end)
3031 FAIL("Trailing \\");
3034 /* Do not generate `unrecognized' warnings here, we fall
3035 back into the quick-grab loop below */
3041 if (RExC_flags16 & PMf_EXTENDED) {
3042 while (RExC_parse < RExC_end && *RExC_parse != '\n') RExC_parse++;
3043 if (RExC_parse < RExC_end)
3049 register STRLEN len;
3055 U8 tmpbuf[UTF8_MAXLEN_FOLD+1], *foldbuf;
3057 parse_start = RExC_parse - 1;
3063 ret = reg_node(pRExC_state, FOLD
3064 ? (LOC ? EXACTFL : EXACTF)
3067 for (len = 0, p = RExC_parse - 1;
3068 len < 127 && p < RExC_end;
3073 if (RExC_flags16 & PMf_EXTENDED)
3074 p = regwhite(p, RExC_end);
3121 ender = ASCII_TO_NATIVE('\033');
3125 ender = ASCII_TO_NATIVE('\007');
3130 char* e = strchr(p, '}');
3134 vFAIL("Missing right brace on \\x{}");
3137 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3138 | PERL_SCAN_DISALLOW_PREFIX;
3140 ender = grok_hex(p + 1, &numlen, &flags, NULL);
3143 /* numlen is generous */
3144 if (numlen + len >= 127) {
3152 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
3154 ender = grok_hex(p, &numlen, &flags, NULL);
3160 ender = UCHARAT(p++);
3161 ender = toCTRL(ender);
3163 case '0': case '1': case '2': case '3':case '4':
3164 case '5': case '6': case '7': case '8':case '9':
3166 (isDIGIT(p[1]) && atoi(p) >= RExC_npar) ) {
3169 ender = grok_oct(p, &numlen, &flags, NULL);
3179 FAIL("Trailing \\");
3182 if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && isALPHA(*p))
3183 vWARN2(p + 1, "Unrecognized escape \\%c passed through", UCHARAT(p));
3184 goto normal_default;
3189 if (UTF8_IS_START(*p) && UTF) {
3190 ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
3198 if (RExC_flags16 & PMf_EXTENDED)
3199 p = regwhite(p, RExC_end);
3201 /* Prime the casefolded buffer. */
3202 ender = toFOLD_uni(ender, tmpbuf, &foldlen);
3204 if (ISMULT2(p)) { /* Back off on ?+*. */
3211 /* Emit all the Unicode characters. */
3212 for (foldbuf = tmpbuf;
3214 foldlen -= numlen) {
3215 ender = utf8_to_uvchr(foldbuf, &numlen);
3217 reguni(pRExC_state, ender, s, &unilen);
3220 /* In EBCDIC the numlen
3221 * and unilen can differ. */
3223 if (numlen >= foldlen)
3227 break; /* "Can't happen." */
3231 reguni(pRExC_state, ender, s, &unilen);
3248 /* Emit all the Unicode characters. */
3249 for (foldbuf = tmpbuf;
3251 foldlen -= numlen) {
3252 ender = utf8_to_uvchr(foldbuf, &numlen);
3254 reguni(pRExC_state, ender, s, &unilen);
3257 /* In EBCDIC the numlen
3258 * and unilen can differ. */
3260 if (numlen >= foldlen)
3268 reguni(pRExC_state, ender, s, &unilen);
3281 Set_Node_Cur_Length(ret); /* MJD */
3282 nextchar(pRExC_state);
3284 /* len is STRLEN which is unsigned, need to copy to signed */
3287 vFAIL("Internal disaster");
3296 RExC_size += STR_SZ(len);
3298 RExC_emit += STR_SZ(len);
3303 /* If the encoding pragma is in effect recode the text of
3304 * any EXACT-kind nodes. */
3305 if (PL_encoding && PL_regkind[(U8)OP(ret)] == EXACT) {
3306 STRLEN oldlen = STR_LEN(ret);
3307 SV *sv = sv_2mortal(newSVpvn(STRING(ret), oldlen));
3311 if (sv_utf8_downgrade(sv, TRUE)) {
3312 char *s = sv_recode_to_utf8(sv, PL_encoding);
3313 STRLEN newlen = SvCUR(sv);
3316 DEBUG_r(PerlIO_printf(Perl_debug_log, "recode %*s to %*s\n",
3317 (int)oldlen, STRING(ret),
3319 Copy(s, STRING(ret), newlen, char);
3320 STR_LEN(ret) += newlen - oldlen;
3321 RExC_emit += STR_SZ(newlen) - STR_SZ(oldlen);
3323 RExC_size += STR_SZ(newlen) - STR_SZ(oldlen);
3331 S_regwhite(pTHX_ char *p, char *e)
3336 else if (*p == '#') {
3339 } while (p < e && *p != '\n');
3347 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
3348 Character classes ([:foo:]) can also be negated ([:^foo:]).
3349 Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
3350 Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
3351 but trigger failures because they are currently unimplemented. */
3353 #define POSIXCC_DONE(c) ((c) == ':')
3354 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
3355 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
3358 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
3361 I32 namedclass = OOB_NAMEDCLASS;
3363 if (value == '[' && RExC_parse + 1 < RExC_end &&
3364 /* I smell either [: or [= or [. -- POSIX has been here, right? */
3365 POSIXCC(UCHARAT(RExC_parse))) {
3366 char c = UCHARAT(RExC_parse);
3367 char* s = RExC_parse++;
3369 while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
3371 if (RExC_parse == RExC_end)
3372 /* Grandfather lone [:, [=, [. */
3375 char* t = RExC_parse++; /* skip over the c */
3377 if (UCHARAT(RExC_parse) == ']') {
3378 RExC_parse++; /* skip over the ending ] */
3381 I32 complement = *posixcc == '^' ? *posixcc++ : 0;
3382 I32 skip = 5; /* the most common skip */
3386 if (strnEQ(posixcc, "alnum", 5))
3388 complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
3389 else if (strnEQ(posixcc, "alpha", 5))
3391 complement ? ANYOF_NALPHA : ANYOF_ALPHA;
3392 else if (strnEQ(posixcc, "ascii", 5))
3394 complement ? ANYOF_NASCII : ANYOF_ASCII;
3397 if (strnEQ(posixcc, "blank", 5))
3399 complement ? ANYOF_NBLANK : ANYOF_BLANK;
3402 if (strnEQ(posixcc, "cntrl", 5))
3404 complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
3407 if (strnEQ(posixcc, "digit", 5))
3409 complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
3412 if (strnEQ(posixcc, "graph", 5))
3414 complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
3417 if (strnEQ(posixcc, "lower", 5))
3419 complement ? ANYOF_NLOWER : ANYOF_LOWER;
3422 if (strnEQ(posixcc, "print", 5))
3424 complement ? ANYOF_NPRINT : ANYOF_PRINT;
3425 else if (strnEQ(posixcc, "punct", 5))
3427 complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
3430 if (strnEQ(posixcc, "space", 5))
3432 complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
3435 if (strnEQ(posixcc, "upper", 5))
3437 complement ? ANYOF_NUPPER : ANYOF_UPPER;
3439 case 'w': /* this is not POSIX, this is the Perl \w */
3440 if (strnEQ(posixcc, "word", 4)) {
3442 complement ? ANYOF_NALNUM : ANYOF_ALNUM;
3447 if (strnEQ(posixcc, "xdigit", 6)) {
3449 complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
3454 if (namedclass == OOB_NAMEDCLASS ||
3455 posixcc[skip] != ':' ||
3456 posixcc[skip+1] != ']')
3458 Simple_vFAIL3("POSIX class [:%.*s:] unknown",
3461 } else if (!SIZE_ONLY) {
3462 /* [[=foo=]] and [[.foo.]] are still future. */
3464 /* adjust RExC_parse so the warning shows after
3466 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
3468 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
3471 /* Maternal grandfather:
3472 * "[:" ending in ":" but not in ":]" */
3482 S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
3484 if (!SIZE_ONLY && POSIXCC(UCHARAT(RExC_parse))) {
3485 char *s = RExC_parse;
3488 while(*s && isALNUM(*s))
3490 if (*s && c == *s && s[1] == ']') {
3491 if (ckWARN(WARN_REGEXP))
3493 "POSIX syntax [%c %c] belongs inside character classes",
3496 /* [[=foo=]] and [[.foo.]] are still future. */
3497 if (POSIXCC_NOTYET(c)) {
3498 /* adjust RExC_parse so the error shows after
3500 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
3502 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
3509 S_regclass(pTHX_ RExC_state_t *pRExC_state)
3512 register UV nextvalue;
3513 register IV prevvalue = OOB_UNICODE;
3514 register IV range = 0;
3515 register regnode *ret;
3518 char *rangebegin = 0;
3519 bool need_class = 0;
3520 SV *listsv = Nullsv;
3523 bool optimize_invert = TRUE;
3524 AV* unicode_alternate = 0;
3526 ret = reganode(pRExC_state, ANYOF, 0);
3529 ANYOF_FLAGS(ret) = 0;
3531 if (UCHARAT(RExC_parse) == '^') { /* Complement of range. */
3535 ANYOF_FLAGS(ret) |= ANYOF_INVERT;
3539 RExC_size += ANYOF_SKIP;
3541 RExC_emit += ANYOF_SKIP;
3543 ANYOF_FLAGS(ret) |= ANYOF_FOLD;
3545 ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
3546 ANYOF_BITMAP_ZERO(ret);
3547 listsv = newSVpvn("# comment\n", 10);
3550 nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
3552 if (!SIZE_ONLY && POSIXCC(nextvalue))
3553 checkposixcc(pRExC_state);
3555 /* allow 1st char to be ] (allowing it to be - is dealt with later) */
3556 if (UCHARAT(RExC_parse) == ']')
3559 while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
3563 namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
3566 rangebegin = RExC_parse;
3568 value = utf8n_to_uvchr((U8*)RExC_parse,
3569 RExC_end - RExC_parse,
3571 RExC_parse += numlen;
3574 value = UCHARAT(RExC_parse++);
3575 nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
3576 if (value == '[' && POSIXCC(nextvalue))
3577 namedclass = regpposixcc(pRExC_state, value);
3578 else if (value == '\\') {
3580 value = utf8n_to_uvchr((U8*)RExC_parse,
3581 RExC_end - RExC_parse,
3583 RExC_parse += numlen;
3586 value = UCHARAT(RExC_parse++);
3587 /* Some compilers cannot handle switching on 64-bit integer
3588 * values, therefore value cannot be an UV. Yes, this will
3589 * be a problem later if we want switch on Unicode.
3590 * A similar issue a little bit later when switching on
3591 * namedclass. --jhi */
3592 switch ((I32)value) {
3593 case 'w': namedclass = ANYOF_ALNUM; break;
3594 case 'W': namedclass = ANYOF_NALNUM; break;
3595 case 's': namedclass = ANYOF_SPACE; break;
3596 case 'S': namedclass = ANYOF_NSPACE; break;
3597 case 'd': namedclass = ANYOF_DIGIT; break;
3598 case 'D': namedclass = ANYOF_NDIGIT; break;
3601 if (RExC_parse >= RExC_end)
3602 vFAIL2("Empty \\%c{}", (U8)value);
3603 if (*RExC_parse == '{') {
3605 e = strchr(RExC_parse++, '}');
3607 vFAIL2("Missing right brace on \\%c{}", c);
3608 while (isSPACE(UCHARAT(RExC_parse)))
3610 if (e == RExC_parse)
3611 vFAIL2("Empty \\%c{}", c);
3613 while (isSPACE(UCHARAT(RExC_parse + n - 1)))
3621 if (UCHARAT(RExC_parse) == '^') {
3624 value = value == 'p' ? 'P' : 'p'; /* toggle */
3625 while (isSPACE(UCHARAT(RExC_parse))) {
3631 Perl_sv_catpvf(aTHX_ listsv,
3632 "+utf8::%.*s\n", (int)n, RExC_parse);
3634 Perl_sv_catpvf(aTHX_ listsv,
3635 "!utf8::%.*s\n", (int)n, RExC_parse);
3638 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
3640 case 'n': value = '\n'; break;
3641 case 'r': value = '\r'; break;
3642 case 't': value = '\t'; break;
3643 case 'f': value = '\f'; break;
3644 case 'b': value = '\b'; break;
3645 case 'e': value = ASCII_TO_NATIVE('\033');break;
3646 case 'a': value = ASCII_TO_NATIVE('\007');break;
3648 if (*RExC_parse == '{') {
3649 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3650 | PERL_SCAN_DISALLOW_PREFIX;
3651 e = strchr(RExC_parse++, '}');
3653 vFAIL("Missing right brace on \\x{}");
3655 numlen = e - RExC_parse;
3656 value = grok_hex(RExC_parse, &numlen, &flags, NULL);
3660 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
3662 value = grok_hex(RExC_parse, &numlen, &flags, NULL);
3663 RExC_parse += numlen;
3667 value = UCHARAT(RExC_parse++);
3668 value = toCTRL(value);
3670 case '0': case '1': case '2': case '3': case '4':
3671 case '5': case '6': case '7': case '8': case '9':
3675 value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
3676 RExC_parse += numlen;
3680 if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && isALPHA(value))
3682 "Unrecognized escape \\%c in character class passed through",
3686 } /* end of \blah */
3688 if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
3690 if (!SIZE_ONLY && !need_class)
3691 ANYOF_CLASS_ZERO(ret);
3695 /* a bad range like a-\d, a-[:digit:] ? */
3698 if (ckWARN(WARN_REGEXP))
3700 "False [] range \"%*.*s\"",
3701 RExC_parse - rangebegin,
3702 RExC_parse - rangebegin,
3704 if (prevvalue < 256) {
3705 ANYOF_BITMAP_SET(ret, prevvalue);
3706 ANYOF_BITMAP_SET(ret, '-');
3709 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
3710 Perl_sv_catpvf(aTHX_ listsv,
3711 "%04"UVxf"\n%04"UVxf"\n", (UV)prevvalue, (UV) '-');
3715 range = 0; /* this was not a true range */
3719 if (namedclass > OOB_NAMEDCLASS)
3720 optimize_invert = FALSE;
3721 /* Possible truncation here but in some 64-bit environments
3722 * the compiler gets heartburn about switch on 64-bit values.
3723 * A similar issue a little earlier when switching on value.
3725 switch ((I32)namedclass) {
3728 ANYOF_CLASS_SET(ret, ANYOF_ALNUM);
3730 for (value = 0; value < 256; value++)
3732 ANYOF_BITMAP_SET(ret, value);
3734 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsWord\n");
3738 ANYOF_CLASS_SET(ret, ANYOF_NALNUM);
3740 for (value = 0; value < 256; value++)
3741 if (!isALNUM(value))
3742 ANYOF_BITMAP_SET(ret, value);
3744 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsWord\n");
3748 ANYOF_CLASS_SET(ret, ANYOF_ALNUMC);
3750 for (value = 0; value < 256; value++)
3751 if (isALNUMC(value))
3752 ANYOF_BITMAP_SET(ret, value);
3754 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsAlnum\n");
3758 ANYOF_CLASS_SET(ret, ANYOF_NALNUMC);
3760 for (value = 0; value < 256; value++)
3761 if (!isALNUMC(value))
3762 ANYOF_BITMAP_SET(ret, value);
3764 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsAlnum\n");
3768 ANYOF_CLASS_SET(ret, ANYOF_ALPHA);
3770 for (value = 0; value < 256; value++)
3772 ANYOF_BITMAP_SET(ret, value);
3774 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsAlpha\n");
3778 ANYOF_CLASS_SET(ret, ANYOF_NALPHA);
3780 for (value = 0; value < 256; value++)
3781 if (!isALPHA(value))
3782 ANYOF_BITMAP_SET(ret, value);
3784 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsAlpha\n");
3788 ANYOF_CLASS_SET(ret, ANYOF_ASCII);
3791 for (value = 0; value < 128; value++)
3792 ANYOF_BITMAP_SET(ret, value);
3794 for (value = 0; value < 256; value++) {
3796 ANYOF_BITMAP_SET(ret, value);
3800 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsASCII\n");
3804 ANYOF_CLASS_SET(ret, ANYOF_NASCII);
3807 for (value = 128; value < 256; value++)
3808 ANYOF_BITMAP_SET(ret, value);
3810 for (value = 0; value < 256; value++) {
3811 if (!isASCII(value))
3812 ANYOF_BITMAP_SET(ret, value);
3816 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsASCII\n");
3820 ANYOF_CLASS_SET(ret, ANYOF_BLANK);
3822 for (value = 0; value < 256; value++)
3824 ANYOF_BITMAP_SET(ret, value);
3826 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsBlank\n");
3830 ANYOF_CLASS_SET(ret, ANYOF_NBLANK);
3832 for (value = 0; value < 256; value++)
3833 if (!isBLANK(value))
3834 ANYOF_BITMAP_SET(ret, value);
3836 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsBlank\n");
3840 ANYOF_CLASS_SET(ret, ANYOF_CNTRL);
3842 for (value = 0; value < 256; value++)
3844 ANYOF_BITMAP_SET(ret, value);
3846 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsCntrl\n");
3850 ANYOF_CLASS_SET(ret, ANYOF_NCNTRL);
3852 for (value = 0; value < 256; value++)
3853 if (!isCNTRL(value))
3854 ANYOF_BITMAP_SET(ret, value);
3856 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsCntrl\n");
3860 ANYOF_CLASS_SET(ret, ANYOF_DIGIT);
3862 /* consecutive digits assumed */
3863 for (value = '0'; value <= '9'; value++)
3864 ANYOF_BITMAP_SET(ret, value);
3866 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsDigit\n");
3870 ANYOF_CLASS_SET(ret, ANYOF_NDIGIT);
3872 /* consecutive digits assumed */
3873 for (value = 0; value < '0'; value++)
3874 ANYOF_BITMAP_SET(ret, value);
3875 for (value = '9' + 1; value < 256; value++)
3876 ANYOF_BITMAP_SET(ret, value);
3878 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsDigit\n");
3882 ANYOF_CLASS_SET(ret, ANYOF_GRAPH);
3884 for (value = 0; value < 256; value++)
3886 ANYOF_BITMAP_SET(ret, value);
3888 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsGraph\n");
3892 ANYOF_CLASS_SET(ret, ANYOF_NGRAPH);
3894 for (value = 0; value < 256; value++)
3895 if (!isGRAPH(value))
3896 ANYOF_BITMAP_SET(ret, value);
3898 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsGraph\n");
3902 ANYOF_CLASS_SET(ret, ANYOF_LOWER);
3904 for (value = 0; value < 256; value++)
3906 ANYOF_BITMAP_SET(ret, value);
3908 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsLower\n");
3912 ANYOF_CLASS_SET(ret, ANYOF_NLOWER);
3914 for (value = 0; value < 256; value++)
3915 if (!isLOWER(value))
3916 ANYOF_BITMAP_SET(ret, value);
3918 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsLower\n");
3922 ANYOF_CLASS_SET(ret, ANYOF_PRINT);
3924 for (value = 0; value < 256; value++)
3926 ANYOF_BITMAP_SET(ret, value);
3928 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsPrint\n");
3932 ANYOF_CLASS_SET(ret, ANYOF_NPRINT);
3934 for (value = 0; value < 256; value++)
3935 if (!isPRINT(value))
3936 ANYOF_BITMAP_SET(ret, value);
3938 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsPrint\n");
3942 ANYOF_CLASS_SET(ret, ANYOF_PSXSPC);
3944 for (value = 0; value < 256; value++)
3945 if (isPSXSPC(value))
3946 ANYOF_BITMAP_SET(ret, value);
3948 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsSpace\n");
3952 ANYOF_CLASS_SET(ret, ANYOF_NPSXSPC);
3954 for (value = 0; value < 256; value++)
3955 if (!isPSXSPC(value))
3956 ANYOF_BITMAP_SET(ret, value);
3958 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsSpace\n");
3962 ANYOF_CLASS_SET(ret, ANYOF_PUNCT);
3964 for (value = 0; value < 256; value++)
3966 ANYOF_BITMAP_SET(ret, value);
3968 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsPunct\n");
3972 ANYOF_CLASS_SET(ret, ANYOF_NPUNCT);
3974 for (value = 0; value < 256; value++)
3975 if (!isPUNCT(value))
3976 ANYOF_BITMAP_SET(ret, value);
3978 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsPunct\n");
3982 ANYOF_CLASS_SET(ret, ANYOF_SPACE);
3984 for (value = 0; value < 256; value++)
3986 ANYOF_BITMAP_SET(ret, value);
3988 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsSpacePerl\n");
3992 ANYOF_CLASS_SET(ret, ANYOF_NSPACE);
3994 for (value = 0; value < 256; value++)
3995 if (!isSPACE(value))
3996 ANYOF_BITMAP_SET(ret, value);
3998 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsSpacePerl\n");
4002 ANYOF_CLASS_SET(ret, ANYOF_UPPER);
4004 for (value = 0; value < 256; value++)
4006 ANYOF_BITMAP_SET(ret, value);
4008 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsUpper\n");
4012 ANYOF_CLASS_SET(ret, ANYOF_NUPPER);
4014 for (value = 0; value < 256; value++)
4015 if (!isUPPER(value))
4016 ANYOF_BITMAP_SET(ret, value);
4018 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsUpper\n");
4022 ANYOF_CLASS_SET(ret, ANYOF_XDIGIT);
4024 for (value = 0; value < 256; value++)
4025 if (isXDIGIT(value))
4026 ANYOF_BITMAP_SET(ret, value);
4028 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsXDigit\n");
4032 ANYOF_CLASS_SET(ret, ANYOF_NXDIGIT);
4034 for (value = 0; value < 256; value++)
4035 if (!isXDIGIT(value))
4036 ANYOF_BITMAP_SET(ret, value);
4038 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsXDigit\n");
4041 vFAIL("Invalid [::] class");
4045 ANYOF_FLAGS(ret) |= ANYOF_CLASS;
4048 } /* end of namedclass \blah */
4051 if (prevvalue > value) /* b-a */ {
4052 Simple_vFAIL4("Invalid [] range \"%*.*s\"",
4053 RExC_parse - rangebegin,
4054 RExC_parse - rangebegin,
4056 range = 0; /* not a valid range */
4060 prevvalue = value; /* save the beginning of the range */
4061 if (*RExC_parse == '-' && RExC_parse+1 < RExC_end &&
4062 RExC_parse[1] != ']') {
4065 /* a bad range like \w-, [:word:]- ? */
4066 if (namedclass > OOB_NAMEDCLASS) {
4067 if (ckWARN(WARN_REGEXP))
4069 "False [] range \"%*.*s\"",
4070 RExC_parse - rangebegin,
4071 RExC_parse - rangebegin,
4074 ANYOF_BITMAP_SET(ret, '-');
4076 range = 1; /* yeah, it's a range! */
4077 continue; /* but do it the next time */
4081 /* now is the next time */
4085 if (prevvalue < 256) {
4086 IV ceilvalue = value < 256 ? value : 255;
4089 if ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
4090 (isUPPER(prevvalue) && isUPPER(ceilvalue)))
4092 if (isLOWER(prevvalue)) {
4093 for (i = prevvalue; i <= ceilvalue; i++)
4095 ANYOF_BITMAP_SET(ret, i);
4097 for (i = prevvalue; i <= ceilvalue; i++)
4099 ANYOF_BITMAP_SET(ret, i);
4104 for (i = prevvalue; i <= ceilvalue; i++)
4105 ANYOF_BITMAP_SET(ret, i);
4107 if (value > 255 || UTF) {
4108 UV prevnatvalue = NATIVE_TO_UNI(prevvalue);
4109 UV natvalue = NATIVE_TO_UNI(value);
4111 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
4112 if (prevnatvalue < natvalue) { /* what about > ? */
4113 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
4114 prevnatvalue, natvalue);
4116 else if (prevnatvalue == natvalue) {
4117 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", natvalue);
4119 U8 foldbuf[UTF8_MAXLEN_FOLD+1];
4121 UV f = to_uni_fold(natvalue, foldbuf, &foldlen);
4123 /* If folding and foldable and a single
4124 * character, insert also the folded version
4125 * to the charclass. */
4127 if (foldlen == UNISKIP(f))
4128 Perl_sv_catpvf(aTHX_ listsv,
4131 /* Any multicharacter foldings
4132 * require the following transform:
4133 * [ABCDEF] -> (?:[ABCabcDEFd]|pq|rst)
4134 * where E folds into "pq" and F folds
4135 * into "rst", all other characters
4136 * fold to single characters. We save
4137 * away these multicharacter foldings,
4138 * to be later saved as part of the
4139 * additional "s" data. */
4142 if (!unicode_alternate)
4143 unicode_alternate = newAV();
4144 sv = newSVpvn((char*)foldbuf, foldlen);
4146 av_push(unicode_alternate, sv);
4150 /* If folding and the value is one of the Greek
4151 * sigmas insert a few more sigmas to make the
4152 * folding rules of the sigmas to work right.
4153 * Note that not all the possible combinations
4154 * are handled here: some of them are handled
4155 * by the standard folding rules, and some of
4156 * them (literal or EXACTF cases) are handled
4157 * during runtime in regexec.c:S_find_byclass(). */
4158 if (value == UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA) {
4159 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
4160 (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA);
4161 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
4162 (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
4164 else if (value == UNICODE_GREEK_CAPITAL_LETTER_SIGMA)
4165 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
4166 (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
4172 range = 0; /* this range (if it was one) is done now */
4176 ANYOF_FLAGS(ret) |= ANYOF_LARGE;
4178 RExC_size += ANYOF_CLASS_ADD_SKIP;
4180 RExC_emit += ANYOF_CLASS_ADD_SKIP;
4183 /* optimize case-insensitive simple patterns (e.g. /[a-z]/i) */
4185 /* If the only flag is folding (plus possibly inversion). */
4186 ((ANYOF_FLAGS(ret) & (ANYOF_FLAGS_ALL ^ ANYOF_INVERT)) == ANYOF_FOLD)
4188 for (value = 0; value < 256; ++value) {
4189 if (ANYOF_BITMAP_TEST(ret, value)) {
4190 IV fold = PL_fold[value];
4193 ANYOF_BITMAP_SET(ret, fold);
4196 ANYOF_FLAGS(ret) &= ~ANYOF_FOLD;
4199 /* optimize inverted simple patterns (e.g. [^a-z]) */
4200 if (!SIZE_ONLY && optimize_invert &&
4201 /* If the only flag is inversion. */
4202 (ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT) {
4203 for (value = 0; value < ANYOF_BITMAP_SIZE; ++value)
4204 ANYOF_BITMAP(ret)[value] ^= ANYOF_FLAGS_ALL;
4205 ANYOF_FLAGS(ret) = ANYOF_UNICODE_ALL;
4212 /* The 0th element stores the character class description
4213 * in its textual form: used later (regexec.c:Perl_regclass_swatch())
4214 * to initialize the appropriate swash (which gets stored in
4215 * the 1st element), and also useful for dumping the regnode.
4216 * The 2nd element stores the multicharacter foldings,
4217 * used later (regexec.c:s_reginclasslen()). */
4218 av_store(av, 0, listsv);
4219 av_store(av, 1, NULL);
4220 av_store(av, 2, (SV*)unicode_alternate);
4221 rv = newRV_noinc((SV*)av);
4222 n = add_data(pRExC_state, 1, "s");
4223 RExC_rx->data->data[n] = (void*)rv;
4231 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
4233 char* retval = RExC_parse++;
4236 if (*RExC_parse == '(' && RExC_parse[1] == '?' &&
4237 RExC_parse[2] == '#') {
4238 while (*RExC_parse && *RExC_parse != ')')
4243 if (RExC_flags16 & PMf_EXTENDED) {
4244 if (isSPACE(*RExC_parse)) {
4248 else if (*RExC_parse == '#') {
4249 while (*RExC_parse && *RExC_parse != '\n')
4260 - reg_node - emit a node
4262 STATIC regnode * /* Location. */
4263 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
4265 register regnode *ret;
4266 register regnode *ptr;
4270 SIZE_ALIGN(RExC_size);
4275 NODE_ALIGN_FILL(ret);
4277 FILL_ADVANCE_NODE(ptr, op);
4278 if (RExC_offsets) { /* MJD */
4279 MJD_OFFSET_DEBUG((stderr, "%s:%u: (op %s) %s %u <- %u (len %u) (max %u).\n",
4280 "reg_node", __LINE__,
4282 RExC_emit - RExC_emit_start > RExC_offsets[0]
4283 ? "Overwriting end of array!\n" : "OK",
4284 RExC_emit - RExC_emit_start,
4285 RExC_parse - RExC_start,
4287 Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
4296 - reganode - emit a node with an argument
4298 STATIC regnode * /* Location. */
4299 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
4301 register regnode *ret;
4302 register regnode *ptr;
4306 SIZE_ALIGN(RExC_size);
4311 NODE_ALIGN_FILL(ret);
4313 FILL_ADVANCE_NODE_ARG(ptr, op, arg);
4314 if (RExC_offsets) { /* MJD */
4315 MJD_OFFSET_DEBUG((stderr, "%s: %s %u <- %u (max %u).\n",
4317 RExC_emit - RExC_emit_start > RExC_offsets[0] ?
4318 "Overwriting end of array!\n" : "OK",
4319 RExC_emit - RExC_emit_start,
4320 RExC_parse - RExC_start,
4322 Set_Cur_Node_Offset;
4331 - reguni - emit (if appropriate) a Unicode character
4334 S_reguni(pTHX_ RExC_state_t *pRExC_state, UV uv, char* s, STRLEN* lenp)
4336 *lenp = SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
4340 - reginsert - insert an operator in front of already-emitted operand
4342 * Means relocating the operand.
4345 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd)
4347 register regnode *src;
4348 register regnode *dst;
4349 register regnode *place;
4350 register int offset = regarglen[(U8)op];
4352 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
4355 RExC_size += NODE_STEP_REGNODE + offset;
4360 RExC_emit += NODE_STEP_REGNODE + offset;
4362 while (src > opnd) {
4363 StructCopy(--src, --dst, regnode);
4364 if (RExC_offsets) { /* MJD 20010112 */
4365 MJD_OFFSET_DEBUG((stderr, "%s: %s copy %u -> %u (max %u).\n",
4367 dst - RExC_emit_start > RExC_offsets[0]
4368 ? "Overwriting end of array!\n" : "OK",
4369 src - RExC_emit_start,
4370 dst - RExC_emit_start,
4372 Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
4373 Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
4378 place = opnd; /* Op node, where operand used to be. */
4379 if (RExC_offsets) { /* MJD */
4380 MJD_OFFSET_DEBUG((stderr, "%s: %s %u <- %u (max %u).\n",
4382 place - RExC_emit_start > RExC_offsets[0]
4383 ? "Overwriting end of array!\n" : "OK",
4384 place - RExC_emit_start,
4385 RExC_parse - RExC_start,
4387 Set_Node_Offset(place, RExC_parse);
4389 src = NEXTOPER(place);
4390 FILL_ADVANCE_NODE(place, op);
4391 Zero(src, offset, regnode);
4395 - regtail - set the next-pointer at the end of a node chain of p to val.
4398 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, regnode *val)
4400 register regnode *scan;
4401 register regnode *temp;
4406 /* Find last node. */
4409 temp = regnext(scan);
4415 if (reg_off_by_arg[OP(scan)]) {
4416 ARG_SET(scan, val - scan);
4419 NEXT_OFF(scan) = val - scan;
4424 - regoptail - regtail on operand of first argument; nop if operandless
4427 S_regoptail(pTHX_ RExC_state_t *pRExC_state, regnode *p, regnode *val)
4429 /* "Operandless" and "op != BRANCH" are synonymous in practice. */
4430 if (p == NULL || SIZE_ONLY)
4432 if (PL_regkind[(U8)OP(p)] == BRANCH) {
4433 regtail(pRExC_state, NEXTOPER(p), val);
4435 else if ( PL_regkind[(U8)OP(p)] == BRANCHJ) {
4436 regtail(pRExC_state, NEXTOPER(NEXTOPER(p)), val);
4443 - regcurly - a little FSA that accepts {\d+,?\d*}
4446 S_regcurly(pTHX_ register char *s)
4467 S_dumpuntil(pTHX_ regnode *start, regnode *node, regnode *last, SV* sv, I32 l)
4469 register U8 op = EXACT; /* Arbitrary non-END op. */
4470 register regnode *next;
4472 while (op != END && (!last || node < last)) {
4473 /* While that wasn't END last time... */
4479 next = regnext(node);
4481 if (OP(node) == OPTIMIZED)
4484 PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
4485 (int)(2*l + 1), "", SvPVX(sv));
4486 if (next == NULL) /* Next ptr. */
4487 PerlIO_printf(Perl_debug_log, "(0)");
4489 PerlIO_printf(Perl_debug_log, "(%"IVdf")", (IV)(next - start));
4490 (void)PerlIO_putc(Perl_debug_log, '\n');
4492 if (PL_regkind[(U8)op] == BRANCHJ) {
4493 register regnode *nnode = (OP(next) == LONGJMP
4496 if (last && nnode > last)
4498 node = dumpuntil(start, NEXTOPER(NEXTOPER(node)), nnode, sv, l + 1);
4500 else if (PL_regkind[(U8)op] == BRANCH) {
4501 node = dumpuntil(start, NEXTOPER(node), next, sv, l + 1);
4503 else if ( op == CURLY) { /* `next' might be very big: optimizer */
4504 node = dumpuntil(start, NEXTOPER(node) + EXTRA_STEP_2ARGS,
4505 NEXTOPER(node) + EXTRA_STEP_2ARGS + 1, sv, l + 1);
4507 else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
4508 node = dumpuntil(start, NEXTOPER(node) + EXTRA_STEP_2ARGS,
4511 else if ( op == PLUS || op == STAR) {
4512 node = dumpuntil(start, NEXTOPER(node), NEXTOPER(node) + 1, sv, l + 1);
4514 else if (op == ANYOF) {
4515 /* arglen 1 + class block */
4516 node += 1 + ((ANYOF_FLAGS(node) & ANYOF_LARGE)
4517 ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
4518 node = NEXTOPER(node);
4520 else if (PL_regkind[(U8)op] == EXACT) {
4521 /* Literal string, where present. */
4522 node += NODE_SZ_STR(node) - 1;
4523 node = NEXTOPER(node);
4526 node = NEXTOPER(node);
4527 node += regarglen[(U8)op];
4529 if (op == CURLYX || op == OPEN)
4531 else if (op == WHILEM)
4537 #endif /* DEBUGGING */
4540 - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
4543 Perl_regdump(pTHX_ regexp *r)
4546 SV *sv = sv_newmortal();
4548 (void)dumpuntil(r->program, r->program + 1, NULL, sv, 0);
4550 /* Header fields of interest. */
4551 if (r->anchored_substr)
4552 PerlIO_printf(Perl_debug_log,
4553 "anchored `%s%.*s%s'%s at %"IVdf" ",
4555 (int)(SvCUR(r->anchored_substr) - (SvTAIL(r->anchored_substr)!=0)),
4556 SvPVX(r->anchored_substr),
4558 SvTAIL(r->anchored_substr) ? "$" : "",
4559 (IV)r->anchored_offset);
4560 else if (r->anchored_utf8)
4561 PerlIO_printf(Perl_debug_log,
4562 "anchored utf8 `%s%.*s%s'%s at %"IVdf" ",
4564 (int)(SvCUR(r->anchored_utf8) - (SvTAIL(r->anchored_utf8)!=0)),
4565 SvPVX(r->anchored_utf8),
4567 SvTAIL(r->anchored_utf8) ? "$" : "",
4568 (IV)r->anchored_offset);
4569 if (r->float_substr)
4570 PerlIO_printf(Perl_debug_log,
4571 "floating `%s%.*s%s'%s at %"IVdf"..%"UVuf" ",
4573 (int)(SvCUR(r->float_substr) - (SvTAIL(r->float_substr)!=0)),
4574 SvPVX(r->float_substr),
4576 SvTAIL(r->float_substr) ? "$" : "",
4577 (IV)r->float_min_offset, (UV)r->float_max_offset);
4578 else if (r->float_utf8)
4579 PerlIO_printf(Perl_debug_log,
4580 "floating utf8 `%s%.*s%s'%s at %"IVdf"..%"UVuf" ",
4582 (int)(SvCUR(r->float_utf8) - (SvTAIL(r->float_utf8)!=0)),
4583 SvPVX(r->float_utf8),
4585 SvTAIL(r->float_utf8) ? "$" : "",
4586 (IV)r->float_min_offset, (UV)r->float_max_offset);
4587 if (r->check_substr || r->check_utf8)
4588 PerlIO_printf(Perl_debug_log,
4589 r->check_substr == r->float_substr
4590 && r->check_utf8 == r->float_utf8
4591 ? "(checking floating" : "(checking anchored");
4592 if (r->reganch & ROPT_NOSCAN)
4593 PerlIO_printf(Perl_debug_log, " noscan");
4594 if (r->reganch & ROPT_CHECK_ALL)
4595 PerlIO_printf(Perl_debug_log, " isall");
4596 if (r->check_substr || r->check_utf8)
4597 PerlIO_printf(Perl_debug_log, ") ");
4599 if (r->regstclass) {
4600 regprop(sv, r->regstclass);
4601 PerlIO_printf(Perl_debug_log, "stclass `%s' ", SvPVX(sv));
4603 if (r->reganch & ROPT_ANCH) {
4604 PerlIO_printf(Perl_debug_log, "anchored");
4605 if (r->reganch & ROPT_ANCH_BOL)
4606 PerlIO_printf(Perl_debug_log, "(BOL)");
4607 if (r->reganch & ROPT_ANCH_MBOL)
4608 PerlIO_printf(Perl_debug_log, "(MBOL)");
4609 if (r->reganch & ROPT_ANCH_SBOL)
4610 PerlIO_printf(Perl_debug_log, "(SBOL)");
4611 if (r->reganch & ROPT_ANCH_GPOS)
4612 PerlIO_printf(Perl_debug_log, "(GPOS)");
4613 PerlIO_putc(Perl_debug_log, ' ');
4615 if (r->reganch & ROPT_GPOS_SEEN)
4616 PerlIO_printf(Perl_debug_log, "GPOS ");
4617 if (r->reganch & ROPT_SKIP)
4618 PerlIO_printf(Perl_debug_log, "plus ");
4619 if (r->reganch & ROPT_IMPLICIT)
4620 PerlIO_printf(Perl_debug_log, "implicit ");
4621 PerlIO_printf(Perl_debug_log, "minlen %ld ", (long) r->minlen);
4622 if (r->reganch & ROPT_EVAL_SEEN)
4623 PerlIO_printf(Perl_debug_log, "with eval ");
4624 PerlIO_printf(Perl_debug_log, "\n");
4627 U32 len = r->offsets[0];
4628 PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)r->offsets[0]);
4629 for (i = 1; i <= len; i++)
4630 PerlIO_printf(Perl_debug_log, "%"UVuf"[%"UVuf"] ",
4631 (UV)r->offsets[i*2-1],
4632 (UV)r->offsets[i*2]);
4633 PerlIO_printf(Perl_debug_log, "\n");
4635 #endif /* DEBUGGING */
4641 S_put_byte(pTHX_ SV *sv, int c)
4643 if (isCNTRL(c) || c == 255 || !isPRINT(c))
4644 Perl_sv_catpvf(aTHX_ sv, "\\%o", c);
4645 else if (c == '-' || c == ']' || c == '\\' || c == '^')
4646 Perl_sv_catpvf(aTHX_ sv, "\\%c", c);
4648 Perl_sv_catpvf(aTHX_ sv, "%c", c);
4651 #endif /* DEBUGGING */
4654 - regprop - printable representation of opcode
4657 Perl_regprop(pTHX_ SV *sv, regnode *o)
4662 sv_setpvn(sv, "", 0);
4663 if (OP(o) >= reg_num) /* regnode.type is unsigned */
4664 /* It would be nice to FAIL() here, but this may be called from
4665 regexec.c, and it would be hard to supply pRExC_state. */
4666 Perl_croak(aTHX_ "Corrupted regexp opcode");
4667 sv_catpv(sv, (char*)reg_name[OP(o)]); /* Take off const! */
4669 k = PL_regkind[(U8)OP(o)];
4672 SV *dsv = sv_2mortal(newSVpvn("", 0));
4673 /* Using is_utf8_string() is a crude hack but it may
4674 * be the best for now since we have no flag "this EXACTish
4675 * node was UTF-8" --jhi */
4676 bool do_utf8 = is_utf8_string((U8*)STRING(o), STR_LEN(o));
4678 pv_uni_display(dsv, (U8*)STRING(o), STR_LEN(o), 60,
4679 UNI_DISPLAY_REGEX) :
4684 Perl_sv_catpvf(aTHX_ sv, " <%s%.*s%s>",
4689 else if (k == CURLY) {
4690 if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
4691 Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
4692 Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
4694 else if (k == WHILEM && o->flags) /* Ordinal/of */
4695 Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
4696 else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP )
4697 Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o)); /* Parenth number */
4698 else if (k == LOGICAL)
4699 Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* 2: embedded, otherwise 1 */
4700 else if (k == ANYOF) {
4701 int i, rangestart = -1;
4702 U8 flags = ANYOF_FLAGS(o);
4703 const char * const anyofs[] = { /* Should be syncronized with
4704 * ANYOF_ #xdefines in regcomp.h */
4737 if (flags & ANYOF_LOCALE)
4738 sv_catpv(sv, "{loc}");
4739 if (flags & ANYOF_FOLD)
4740 sv_catpv(sv, "{i}");
4741 Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
4742 if (flags & ANYOF_INVERT)
4744 for (i = 0; i <= 256; i++) {
4745 if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
4746 if (rangestart == -1)
4748 } else if (rangestart != -1) {
4749 if (i <= rangestart + 3)
4750 for (; rangestart < i; rangestart++)
4751 put_byte(sv, rangestart);
4753 put_byte(sv, rangestart);
4755 put_byte(sv, i - 1);
4761 if (o->flags & ANYOF_CLASS)
4762 for (i = 0; i < sizeof(anyofs)/sizeof(char*); i++)
4763 if (ANYOF_CLASS_TEST(o,i))
4764 sv_catpv(sv, anyofs[i]);
4766 if (flags & ANYOF_UNICODE)
4767 sv_catpv(sv, "{unicode}");
4768 else if (flags & ANYOF_UNICODE_ALL)
4769 sv_catpv(sv, "{unicode_all}");
4773 SV *sw = regclass_swash(o, FALSE, &lv, 0);
4778 U8 s[UTF8_MAXLEN+1];
4780 for (i = 0; i <= 256; i++) { /* just the first 256 */
4781 U8 *e = uvchr_to_utf8(s, i);
4783 if (i < 256 && swash_fetch(sw, s, TRUE)) {
4784 if (rangestart == -1)
4786 } else if (rangestart != -1) {
4789 if (i <= rangestart + 3)
4790 for (; rangestart < i; rangestart++) {
4791 for(e = uvchr_to_utf8(s, rangestart), p = s; p < e; p++)
4795 for (e = uvchr_to_utf8(s, rangestart), p = s; p < e; p++)
4798 for (e = uvchr_to_utf8(s, i - 1), p = s; p < e; p++)
4805 sv_catpv(sv, "..."); /* et cetera */
4809 char *s = savepv(SvPVX(lv));
4812 while(*s && *s != '\n') s++;
4833 Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
4835 else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
4836 Perl_sv_catpvf(aTHX_ sv, "[-%d]", o->flags);
4837 #endif /* DEBUGGING */
4841 Perl_re_intuit_string(pTHX_ regexp *prog)
4842 { /* Assume that RE_INTUIT is set */
4845 char *s = SvPV(prog->check_substr
4846 ? prog->check_substr : prog->check_utf8, n_a);
4848 if (!PL_colorset) reginitcolors();
4849 PerlIO_printf(Perl_debug_log,
4850 "%sUsing REx %ssubstr:%s `%s%.60s%s%s'\n",
4852 prog->check_substr ? "" : "utf8 ",
4853 PL_colors[5],PL_colors[0],
4856 (strlen(s) > 60 ? "..." : ""));
4859 return prog->check_substr ? prog->check_substr : prog->check_utf8;
4863 Perl_pregfree(pTHX_ struct regexp *r)
4866 SV *dsv = PERL_DEBUG_PAD_ZERO(0);
4869 if (!r || (--r->refcnt > 0))
4872 char *s = pv_uni_display(dsv, (U8*)r->precomp, r->prelen, 60,
4874 int len = SvCUR(dsv);
4877 PerlIO_printf(Perl_debug_log,
4878 "%sFreeing REx:%s `%s%*.*s%s%s'\n",
4879 PL_colors[4],PL_colors[5],PL_colors[0],
4882 len > 60 ? "..." : "");
4886 Safefree(r->precomp);
4887 if (r->offsets) /* 20010421 MJD */
4888 Safefree(r->offsets);
4889 if (RX_MATCH_COPIED(r))
4890 Safefree(r->subbeg);
4892 if (r->anchored_substr)
4893 SvREFCNT_dec(r->anchored_substr);
4894 if (r->anchored_utf8)
4895 SvREFCNT_dec(r->anchored_utf8);
4896 if (r->float_substr)
4897 SvREFCNT_dec(r->float_substr);
4899 SvREFCNT_dec(r->float_utf8);
4900 Safefree(r->substrs);
4903 int n = r->data->count;
4904 AV* new_comppad = NULL;
4909 /* If you add a ->what type here, update the comment in regcomp.h */
4910 switch (r->data->what[n]) {
4912 SvREFCNT_dec((SV*)r->data->data[n]);
4915 Safefree(r->data->data[n]);
4918 new_comppad = (AV*)r->data->data[n];
4921 if (new_comppad == NULL)
4922 Perl_croak(aTHX_ "panic: pregfree comppad");
4923 old_comppad = PL_comppad;
4924 old_curpad = PL_curpad;
4925 /* Watch out for global destruction's random ordering. */
4926 if (SvTYPE(new_comppad) == SVt_PVAV) {
4927 PL_comppad = new_comppad;
4928 PL_curpad = AvARRAY(new_comppad);
4933 if (!OpREFCNT_dec((OP_4tree*)r->data->data[n])) {
4934 op_free((OP_4tree*)r->data->data[n]);
4937 PL_comppad = old_comppad;
4938 PL_curpad = old_curpad;
4939 SvREFCNT_dec((SV*)new_comppad);
4945 Perl_croak(aTHX_ "panic: regfree data code '%c'", r->data->what[n]);
4948 Safefree(r->data->what);
4951 Safefree(r->startp);
4957 - regnext - dig the "next" pointer out of a node
4959 * [Note, when REGALIGN is defined there are two places in regmatch()
4960 * that bypass this code for speed.]
4963 Perl_regnext(pTHX_ register regnode *p)
4965 register I32 offset;
4967 if (p == &PL_regdummy)
4970 offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
4978 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
4981 STRLEN l1 = strlen(pat1);
4982 STRLEN l2 = strlen(pat2);
4991 Copy(pat1, buf, l1 , char);
4992 Copy(pat2, buf + l1, l2 , char);
4993 buf[l1 + l2] = '\n';
4994 buf[l1 + l2 + 1] = '\0';
4996 /* ANSI variant takes additional second argument */
4997 va_start(args, pat2);
5001 msv = vmess(buf, &args);
5003 message = SvPV(msv,l1);
5006 Copy(message, buf, l1 , char);
5007 buf[l1] = '\0'; /* Overwrite \n */
5008 Perl_croak(aTHX_ "%s", buf);
5011 /* XXX Here's a total kludge. But we need to re-enter for swash routines. */
5014 Perl_save_re_context(pTHX)
5017 SAVEPPTR(RExC_precomp); /* uncompiled string. */
5018 SAVEI32(RExC_npar); /* () count. */
5019 SAVEI32(RExC_size); /* Code size. */
5020 SAVEI16(RExC_flags16); /* are we folding, multilining? */
5021 SAVEVPTR(RExC_rx); /* from regcomp.c */
5022 SAVEI32(RExC_seen); /* from regcomp.c */
5023 SAVEI32(RExC_sawback); /* Did we see \1, ...? */
5024 SAVEI32(RExC_naughty); /* How bad is this pattern? */
5025 SAVEVPTR(RExC_emit); /* Code-emit pointer; ®dummy = don't */
5026 SAVEPPTR(RExC_end); /* End of input for compile */
5027 SAVEPPTR(RExC_parse); /* Input-scan pointer. */
5030 SAVEI32(PL_reg_flags); /* from regexec.c */
5032 SAVEPPTR(PL_reginput); /* String-input pointer. */
5033 SAVEPPTR(PL_regbol); /* Beginning of input, for ^ check. */
5034 SAVEPPTR(PL_regeol); /* End of input, for $ check. */
5035 SAVEVPTR(PL_regstartp); /* Pointer to startp array. */
5036 SAVEVPTR(PL_regendp); /* Ditto for endp. */
5037 SAVEVPTR(PL_reglastparen); /* Similarly for lastparen. */
5038 SAVEPPTR(PL_regtill); /* How far we are required to go. */
5039 SAVEGENERICPV(PL_reg_start_tmp); /* from regexec.c */
5040 PL_reg_start_tmp = 0;
5041 SAVEI32(PL_reg_start_tmpl); /* from regexec.c */
5042 PL_reg_start_tmpl = 0;
5043 SAVEVPTR(PL_regdata);
5044 SAVEI32(PL_reg_eval_set); /* from regexec.c */
5045 SAVEI32(PL_regnarrate); /* from regexec.c */
5046 SAVEVPTR(PL_regprogram); /* from regexec.c */
5047 SAVEINT(PL_regindent); /* from regexec.c */
5048 SAVEVPTR(PL_regcc); /* from regexec.c */
5049 SAVEVPTR(PL_curcop);
5050 SAVEVPTR(PL_reg_call_cc); /* from regexec.c */
5051 SAVEVPTR(PL_reg_re); /* from regexec.c */
5052 SAVEPPTR(PL_reg_ganch); /* from regexec.c */
5053 SAVESPTR(PL_reg_sv); /* from regexec.c */
5054 SAVEI8(PL_reg_match_utf8); /* from regexec.c */
5055 SAVEVPTR(PL_reg_magic); /* from regexec.c */
5056 SAVEI32(PL_reg_oldpos); /* from regexec.c */
5057 SAVEVPTR(PL_reg_oldcurpm); /* from regexec.c */
5058 SAVEVPTR(PL_reg_curpm); /* from regexec.c */
5059 SAVEI32(PL_regnpar); /* () count. */
5060 SAVEI32(PL_regsize); /* from regexec.c */
5062 SAVEPPTR(PL_reg_starttry); /* from regexec.c */
5067 clear_re(pTHX_ void *r)
5069 ReREFCNT_dec((regexp *)r);