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-2001, Larry Wall
74 **** You may distribute under the terms of either the GNU General Public
75 **** License or the Artistic License, as specified in the README file.
78 * Beware that some of this code is subtly aware of the way operator
79 * precedence is structured in regular expressions. Serious changes in
80 * regular-expression syntax might require a total rethink.
83 #define PERL_IN_REGCOMP_C
86 #ifndef PERL_IN_XSUB_RE
98 # if defined(BUGGY_MSC6)
99 /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
100 # pragma optimize("a",off)
101 /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
102 # pragma optimize("w",on )
103 # endif /* BUGGY_MSC6 */
107 #define STATIC static
110 typedef struct RExC_state_t {
111 U16 flags16; /* are we folding, multilining? */
112 char *precomp; /* uncompiled string. */
114 char *start; /* Start of input for compile */
115 char *end; /* End of input for compile */
116 char *parse; /* Input-scan pointer. */
117 I32 whilem_seen; /* number of WHILEM in this expr */
118 regnode *emit_start; /* Start of emitted-code area */
119 regnode *emit; /* Code-emit pointer; ®dummy = don't = compiling */
120 I32 naughty; /* How bad is this pattern? */
121 I32 sawback; /* Did we see \1, ...? */
123 I32 size; /* Code size. */
124 I32 npar; /* () count. */
130 char *starttry; /* -Dr: where regtry was called. */
131 #define RExC_starttry (pRExC_state->starttry)
135 #define RExC_flags16 (pRExC_state->flags16)
136 #define RExC_precomp (pRExC_state->precomp)
137 #define RExC_rx (pRExC_state->rx)
138 #define RExC_start (pRExC_state->start)
139 #define RExC_end (pRExC_state->end)
140 #define RExC_parse (pRExC_state->parse)
141 #define RExC_whilem_seen (pRExC_state->whilem_seen)
142 #define RExC_offsets (pRExC_state->rx->offsets) /* I am not like the others */
143 #define RExC_emit (pRExC_state->emit)
144 #define RExC_emit_start (pRExC_state->emit_start)
145 #define RExC_naughty (pRExC_state->naughty)
146 #define RExC_sawback (pRExC_state->sawback)
147 #define RExC_seen (pRExC_state->seen)
148 #define RExC_size (pRExC_state->size)
149 #define RExC_npar (pRExC_state->npar)
150 #define RExC_extralen (pRExC_state->extralen)
151 #define RExC_seen_zerolen (pRExC_state->seen_zerolen)
152 #define RExC_seen_evals (pRExC_state->seen_evals)
153 #define RExC_utf8 (pRExC_state->utf8)
155 #define ISMULT1(c) ((c) == '*' || (c) == '+' || (c) == '?')
156 #define ISMULT2(s) ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
157 ((*s) == '{' && regcurly(s)))
160 #undef SPSTART /* dratted cpp namespace... */
163 * Flags to be passed up and down.
165 #define WORST 0 /* Worst case. */
166 #define HASWIDTH 0x1 /* Known to match non-null strings. */
167 #define SIMPLE 0x2 /* Simple enough to be STAR/PLUS operand. */
168 #define SPSTART 0x4 /* Starts with * or +. */
169 #define TRYAGAIN 0x8 /* Weeded out a declaration. */
171 /* Length of a variant. */
173 typedef struct scan_data_t {
179 I32 last_end; /* min value, <0 unless valid. */
182 SV **longest; /* Either &l_fixed, or &l_float. */
186 I32 offset_float_min;
187 I32 offset_float_max;
191 struct regnode_charclass_class *start_class;
195 * Forward declarations for pregcomp()'s friends.
198 static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
201 #define SF_BEFORE_EOL (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
202 #define SF_BEFORE_SEOL 0x1
203 #define SF_BEFORE_MEOL 0x2
204 #define SF_FIX_BEFORE_EOL (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
205 #define SF_FL_BEFORE_EOL (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
208 # define SF_FIX_SHIFT_EOL (0+2)
209 # define SF_FL_SHIFT_EOL (0+4)
211 # define SF_FIX_SHIFT_EOL (+2)
212 # define SF_FL_SHIFT_EOL (+4)
215 #define SF_FIX_BEFORE_SEOL (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
216 #define SF_FIX_BEFORE_MEOL (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
218 #define SF_FL_BEFORE_SEOL (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
219 #define SF_FL_BEFORE_MEOL (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
220 #define SF_IS_INF 0x40
221 #define SF_HAS_PAR 0x80
222 #define SF_IN_PAR 0x100
223 #define SF_HAS_EVAL 0x200
224 #define SCF_DO_SUBSTR 0x400
225 #define SCF_DO_STCLASS_AND 0x0800
226 #define SCF_DO_STCLASS_OR 0x1000
227 #define SCF_DO_STCLASS (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
228 #define SCF_WHILEM_VISITED_POS 0x2000
230 #define UTF RExC_utf8
231 #define LOC (RExC_flags16 & PMf_LOCALE)
232 #define FOLD (RExC_flags16 & PMf_FOLD)
234 #define OOB_UNICODE 12345678
235 #define OOB_NAMEDCLASS -1
237 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
238 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
241 /* length of regex to show in messages that don't mark a position within */
242 #define RegexLengthToShowInErrorMessages 127
245 * If MARKER[12] are adjusted, be sure to adjust the constants at the top
246 * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
247 * op/pragma/warn/regcomp.
249 #define MARKER1 "<-- HERE" /* marker as it appears in the description */
250 #define MARKER2 " <-- HERE " /* marker as it appears within the regex */
252 #define REPORT_LOCATION " in regex; marked by " MARKER1 " in m/%.*s" MARKER2 "%s/"
255 * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
256 * arg. Show regex, up to a maximum length. If it's too long, chop and add
261 char *ellipses = ""; \
262 IV len = RExC_end - RExC_precomp; \
265 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \
267 if (len > RegexLengthToShowInErrorMessages) { \
268 /* chop 10 shorter than the max, to ensure meaning of "..." */ \
269 len = RegexLengthToShowInErrorMessages - 10; \
272 Perl_croak(aTHX_ "%s in regex m/%.*s%s/", \
273 msg, (int)len, RExC_precomp, ellipses); \
277 * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
278 * args. Show regex, up to a maximum length. If it's too long, chop and add
281 #define FAIL2(pat,msg) \
283 char *ellipses = ""; \
284 IV len = RExC_end - RExC_precomp; \
287 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \
289 if (len > RegexLengthToShowInErrorMessages) { \
290 /* chop 10 shorter than the max, to ensure meaning of "..." */ \
291 len = RegexLengthToShowInErrorMessages - 10; \
294 S_re_croak2(aTHX_ pat, " in regex m/%.*s%s/", \
295 msg, (int)len, RExC_precomp, ellipses); \
300 * Simple_vFAIL -- like FAIL, but marks the current location in the scan
302 #define Simple_vFAIL(m) \
304 IV offset = RExC_parse - RExC_precomp; \
306 Perl_croak(aTHX_ "%s" REPORT_LOCATION, \
307 m, (int)offset, RExC_precomp, RExC_precomp + offset); \
311 * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
316 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \
321 * Like Simple_vFAIL(), but accepts two arguments.
323 #define Simple_vFAIL2(m,a1) \
325 IV offset = RExC_parse - RExC_precomp; \
327 S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, \
328 (int)offset, RExC_precomp, RExC_precomp + offset); \
332 * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
334 #define vFAIL2(m,a1) \
337 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \
338 Simple_vFAIL2(m, a1); \
343 * Like Simple_vFAIL(), but accepts three arguments.
345 #define Simple_vFAIL3(m, a1, a2) \
347 IV offset = RExC_parse - RExC_precomp; \
349 S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, \
350 (int)offset, RExC_precomp, RExC_precomp + offset); \
354 * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
356 #define vFAIL3(m,a1,a2) \
359 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \
360 Simple_vFAIL3(m, a1, a2); \
364 * Like Simple_vFAIL(), but accepts four arguments.
366 #define Simple_vFAIL4(m, a1, a2, a3) \
368 IV offset = RExC_parse - RExC_precomp; \
370 S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3,\
371 (int)offset, RExC_precomp, RExC_precomp + offset); \
375 * Like Simple_vFAIL(), but accepts five arguments.
377 #define Simple_vFAIL5(m, a1, a2, a3, a4) \
379 IV offset = RExC_parse - RExC_precomp; \
380 S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3, a4,\
381 (int)offset, RExC_precomp, RExC_precomp + offset); \
385 #define vWARN(loc,m) \
387 IV offset = loc - RExC_precomp; \
388 Perl_warner(aTHX_ WARN_REGEXP, "%s" REPORT_LOCATION,\
389 m, (int)offset, RExC_precomp, RExC_precomp + offset); \
392 #define vWARNdep(loc,m) \
394 IV offset = loc - RExC_precomp; \
395 int warn_cat = ckWARN(WARN_REGEXP) ? WARN_REGEXP : WARN_DEPRECATED; \
396 Perl_warner(aTHX_ warn_cat, "%s" REPORT_LOCATION,\
397 m, (int)offset, RExC_precomp, RExC_precomp + offset); \
401 #define vWARN2(loc, m, a1) \
403 IV offset = loc - RExC_precomp; \
404 Perl_warner(aTHX_ WARN_REGEXP, m REPORT_LOCATION,\
406 (int)offset, RExC_precomp, RExC_precomp + offset); \
409 #define vWARN3(loc, m, a1, a2) \
411 IV offset = loc - RExC_precomp; \
412 Perl_warner(aTHX_ WARN_REGEXP, m REPORT_LOCATION, \
414 (int)offset, RExC_precomp, RExC_precomp + offset); \
417 #define vWARN4(loc, m, a1, a2, a3) \
419 IV offset = loc - RExC_precomp; \
420 Perl_warner(aTHX_ WARN_REGEXP, m REPORT_LOCATION,\
422 (int)offset, RExC_precomp, RExC_precomp + offset); \
425 /* used for the parse_flags section for (?c) -- japhy */
426 #define vWARN5(loc, m, a1, a2, a3, a4) \
428 IV offset = loc - RExC_precomp; \
429 Perl_warner(aTHX_ WARN_REGEXP, m REPORT_LOCATION, \
431 (int)offset, RExC_precomp, RExC_precomp + offset); \
435 /* Allow for side effects in s */
436 #define REGC(c,s) STMT_START { if (!SIZE_ONLY) *(s) = (c); else (void)(s);} STMT_END
438 /* Macros for recording node offsets. 20001227 mjd@plover.com
439 * Nodes are numbered 1, 2, 3, 4. Node #n's position is recorded in
440 * element 2*n-1 of the array. Element #2n holds the byte length node #n.
441 * Element 0 holds the number n.
444 #define MJD_OFFSET_DEBUG(x)
445 /* #define MJD_OFFSET_DEBUG(x) fprintf x */
448 # define Set_Node_Offset_To_R(node,byte) \
452 Perl_croak(aTHX_ "value of node is %d in Offset macro", node); \
454 RExC_offsets[2*(node)-1] = (byte); \
459 # define Set_Node_Offset(node,byte) Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
460 # define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
462 # define Set_Node_Length_To_R(node,len) \
465 MJD_OFFSET_DEBUG((stderr, "** (%d) size of node %d is %d.\n", __LINE__, (node), (len))); \
467 Perl_croak(aTHX_ "value of node is %d in Length macro", node); \
469 RExC_offsets[2*(node)] = (len); \
474 # define Set_Node_Length(node,len) Set_Node_Length_To_R((node)-RExC_emit_start, len)
475 # define Set_Cur_Node_Length(len) Set_Node_Length(RExC_emit, len)
476 # define Set_Node_Cur_Length(node) Set_Node_Length(node, RExC_parse - parse_start)
478 /* Get offsets and lengths */
479 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
480 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
482 static void clear_re(pTHX_ void *r);
484 /* Mark that we cannot extend a found fixed substring at this point.
485 Updata the longest found anchored substring and the longest found
486 floating substrings if needed. */
489 S_scan_commit(pTHX_ RExC_state_t *pRExC_state, scan_data_t *data)
491 STRLEN l = CHR_SVLEN(data->last_found);
492 STRLEN old_l = CHR_SVLEN(*data->longest);
494 if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
495 sv_setsv(*data->longest, data->last_found);
496 if (*data->longest == data->longest_fixed) {
497 data->offset_fixed = l ? data->last_start_min : data->pos_min;
498 if (data->flags & SF_BEFORE_EOL)
500 |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
502 data->flags &= ~SF_FIX_BEFORE_EOL;
505 data->offset_float_min = l ? data->last_start_min : data->pos_min;
506 data->offset_float_max = (l
507 ? data->last_start_max
508 : data->pos_min + data->pos_delta);
509 if (data->flags & SF_BEFORE_EOL)
511 |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
513 data->flags &= ~SF_FL_BEFORE_EOL;
516 SvCUR_set(data->last_found, 0);
518 data->flags &= ~SF_BEFORE_EOL;
521 /* Can match anything (initialization) */
523 S_cl_anything(pTHX_ RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
525 ANYOF_CLASS_ZERO(cl);
526 ANYOF_BITMAP_SETALL(cl);
527 cl->flags = ANYOF_EOS|ANYOF_UNICODE_ALL;
529 cl->flags |= ANYOF_LOCALE;
532 /* Can match anything (initialization) */
534 S_cl_is_anything(pTHX_ struct regnode_charclass_class *cl)
538 for (value = 0; value <= ANYOF_MAX; value += 2)
539 if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
541 if (!(cl->flags & ANYOF_UNICODE_ALL))
543 if (!ANYOF_BITMAP_TESTALLSET(cl))
548 /* Can match anything (initialization) */
550 S_cl_init(pTHX_ RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
552 Zero(cl, 1, struct regnode_charclass_class);
554 cl_anything(pRExC_state, cl);
558 S_cl_init_zero(pTHX_ RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
560 Zero(cl, 1, struct regnode_charclass_class);
562 cl_anything(pRExC_state, cl);
564 cl->flags |= ANYOF_LOCALE;
567 /* 'And' a given class with another one. Can create false positives */
568 /* We assume that cl is not inverted */
570 S_cl_and(pTHX_ struct regnode_charclass_class *cl,
571 struct regnode_charclass_class *and_with)
573 if (!(and_with->flags & ANYOF_CLASS)
574 && !(cl->flags & ANYOF_CLASS)
575 && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
576 && !(and_with->flags & ANYOF_FOLD)
577 && !(cl->flags & ANYOF_FOLD)) {
580 if (and_with->flags & ANYOF_INVERT)
581 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
582 cl->bitmap[i] &= ~and_with->bitmap[i];
584 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
585 cl->bitmap[i] &= and_with->bitmap[i];
586 } /* XXXX: logic is complicated otherwise, leave it along for a moment. */
587 if (!(and_with->flags & ANYOF_EOS))
588 cl->flags &= ~ANYOF_EOS;
590 if (cl->flags & ANYOF_UNICODE_ALL && and_with->flags & ANYOF_UNICODE) {
591 cl->flags &= ~ANYOF_UNICODE_ALL;
592 cl->flags |= ANYOF_UNICODE;
593 ARG_SET(cl, ARG(and_with));
595 if (!(and_with->flags & ANYOF_UNICODE_ALL))
596 cl->flags &= ~ANYOF_UNICODE_ALL;
597 if (!(and_with->flags & (ANYOF_UNICODE|ANYOF_UNICODE_ALL)))
598 cl->flags &= ~ANYOF_UNICODE;
601 /* 'OR' a given class with another one. Can create false positives */
602 /* We assume that cl is not inverted */
604 S_cl_or(pTHX_ RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, struct regnode_charclass_class *or_with)
606 if (or_with->flags & ANYOF_INVERT) {
608 * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2))
609 * <= (B1 | !B2) | (CL1 | !CL2)
610 * which is wasteful if CL2 is small, but we ignore CL2:
611 * (B1 | CL1) | (!B2 & !CL2) <= (B1 | CL1) | !B2 = (B1 | !B2) | CL1
612 * XXXX Can we handle case-fold? Unclear:
613 * (OK1(i) | OK1(i')) | !(OK1(i) | OK1(i')) =
614 * (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i'))
616 if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
617 && !(or_with->flags & ANYOF_FOLD)
618 && !(cl->flags & ANYOF_FOLD) ) {
621 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
622 cl->bitmap[i] |= ~or_with->bitmap[i];
623 } /* XXXX: logic is complicated otherwise */
625 cl_anything(pRExC_state, cl);
628 /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
629 if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
630 && (!(or_with->flags & ANYOF_FOLD)
631 || (cl->flags & ANYOF_FOLD)) ) {
634 /* OR char bitmap and class bitmap separately */
635 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
636 cl->bitmap[i] |= or_with->bitmap[i];
637 if (or_with->flags & ANYOF_CLASS) {
638 for (i = 0; i < ANYOF_CLASSBITMAP_SIZE; i++)
639 cl->classflags[i] |= or_with->classflags[i];
640 cl->flags |= ANYOF_CLASS;
643 else { /* XXXX: logic is complicated, leave it along for a moment. */
644 cl_anything(pRExC_state, cl);
647 if (or_with->flags & ANYOF_EOS)
648 cl->flags |= ANYOF_EOS;
650 if (cl->flags & ANYOF_UNICODE && or_with->flags & ANYOF_UNICODE &&
651 ARG(cl) != ARG(or_with)) {
652 cl->flags |= ANYOF_UNICODE_ALL;
653 cl->flags &= ~ANYOF_UNICODE;
655 if (or_with->flags & ANYOF_UNICODE_ALL) {
656 cl->flags |= ANYOF_UNICODE_ALL;
657 cl->flags &= ~ANYOF_UNICODE;
662 * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
663 * These need to be revisited when a newer toolchain becomes available.
665 #if defined(__sparc64__) && defined(__GNUC__)
666 # if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
667 # undef SPARC64_GCC_WORKAROUND
668 # define SPARC64_GCC_WORKAROUND 1
672 /* REx optimizer. Converts nodes into quickier variants "in place".
673 Finds fixed substrings. */
675 /* Stops at toplevel WHILEM as well as at `last'. At end *scanp is set
676 to the position after last scanned or to NULL. */
679 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap, regnode *last, scan_data_t *data, U32 flags)
680 /* scanp: Start here (read-write). */
681 /* deltap: Write maxlen-minlen here. */
682 /* last: Stop before this one. */
684 I32 min = 0, pars = 0, code;
685 regnode *scan = *scanp, *next;
687 int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
688 int is_inf_internal = 0; /* The studied chunk is infinite */
689 I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
690 scan_data_t data_fake;
691 struct regnode_charclass_class and_with; /* Valid if flags & SCF_DO_STCLASS_OR */
693 while (scan && OP(scan) != END && scan < last) {
694 /* Peephole optimizer: */
696 if (PL_regkind[(U8)OP(scan)] == EXACT) {
697 /* Merge several consecutive EXACTish nodes into one. */
698 regnode *n = regnext(scan);
701 regnode *stop = scan;
704 next = scan + NODE_SZ_STR(scan);
705 /* Skip NOTHING, merge EXACT*. */
707 ( PL_regkind[(U8)OP(n)] == NOTHING ||
708 (stringok && (OP(n) == OP(scan))))
710 && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX) {
711 if (OP(n) == TAIL || n > next)
713 if (PL_regkind[(U8)OP(n)] == NOTHING) {
714 NEXT_OFF(scan) += NEXT_OFF(n);
715 next = n + NODE_STEP_REGNODE;
723 int oldl = STR_LEN(scan);
724 regnode *nnext = regnext(n);
726 if (oldl + STR_LEN(n) > U8_MAX)
728 NEXT_OFF(scan) += NEXT_OFF(n);
729 STR_LEN(scan) += STR_LEN(n);
730 next = n + NODE_SZ_STR(n);
731 /* Now we can overwrite *n : */
732 Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
740 if (UTF && OP(scan) == EXACTF && STR_LEN(scan) >= 6) {
742 Two problematic code points in Unicode casefolding of EXACT nodes:
744 U+0390 - GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
745 U+03B0 - GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
751 U+03B9 U+0308 U+0301 0xCE 0xB9 0xCC 0x88 0xCC 0x81
752 U+03C5 U+0308 U+0301 0xCF 0x85 0xCC 0x88 0xCC 0x81
754 This means that in case-insensitive matching (or "loose matching",
755 as Unicode calls it), an EXACTF of length six (the UTF-8 encoded byte
756 length of the above casefolded versions) can match a target string
757 of length two (the byte length of UTF-8 encoded U+0390 or U+03B0).
758 This would rather mess up the minimum length computation.
760 What we'll do is to look for the tail four bytes, and then peek
761 at the preceding two bytes to see whether we need to decrease
762 the minimum length by four (six minus two).
764 Thanks to the design of UTF-8, there cannot be false matches:
765 A sequence of valid UTF-8 bytes cannot be a subsequence of
766 another valid sequence of UTF-8 bytes.
769 char *s0 = STRING(scan), *s, *t;
770 char *s1 = s0 + STR_LEN(scan) - 1, *s2 = s1 - 4;
771 char *t0 = "\xcc\x88\xcc\x81";
775 s < s2 && (t = ninstr(s, s1, t0, t1));
777 if (((U8)t[-1] == 0xB9 && (U8)t[-2] == 0xCE) ||
778 ((U8)t[-1] == 0x85 && (U8)t[-2] == 0xCF))
785 n = scan + NODE_SZ_STR(scan);
787 if (PL_regkind[(U8)OP(n)] != NOTHING || OP(n) == NOTHING) {
795 /* Follow the next-chain of the current node and optimize
796 away all the NOTHINGs from it. */
797 if (OP(scan) != CURLYX) {
798 int max = (reg_off_by_arg[OP(scan)]
800 /* I32 may be smaller than U16 on CRAYs! */
801 : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
802 int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
806 /* Skip NOTHING and LONGJMP. */
807 while ((n = regnext(n))
808 && ((PL_regkind[(U8)OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
809 || ((OP(n) == LONGJMP) && (noff = ARG(n))))
812 if (reg_off_by_arg[OP(scan)])
815 NEXT_OFF(scan) = off;
817 /* The principal pseudo-switch. Cannot be a switch, since we
818 look into several different things. */
819 if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
820 || OP(scan) == IFTHEN || OP(scan) == SUSPEND) {
821 next = regnext(scan);
824 if (OP(next) == code || code == IFTHEN || code == SUSPEND) {
825 I32 max1 = 0, min1 = I32_MAX, num = 0;
826 struct regnode_charclass_class accum;
828 if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
829 scan_commit(pRExC_state, data); /* Cannot merge strings after this. */
830 if (flags & SCF_DO_STCLASS)
831 cl_init_zero(pRExC_state, &accum);
832 while (OP(scan) == code) {
833 I32 deltanext, minnext, f = 0, fake;
834 struct regnode_charclass_class this_class;
839 data_fake.whilem_c = data->whilem_c;
840 data_fake.last_closep = data->last_closep;
843 data_fake.last_closep = &fake;
844 next = regnext(scan);
845 scan = NEXTOPER(scan);
847 scan = NEXTOPER(scan);
848 if (flags & SCF_DO_STCLASS) {
849 cl_init(pRExC_state, &this_class);
850 data_fake.start_class = &this_class;
851 f = SCF_DO_STCLASS_AND;
853 if (flags & SCF_WHILEM_VISITED_POS)
854 f |= SCF_WHILEM_VISITED_POS;
855 /* we suppose the run is continuous, last=next...*/
856 minnext = study_chunk(pRExC_state, &scan, &deltanext,
857 next, &data_fake, f);
860 if (max1 < minnext + deltanext)
861 max1 = minnext + deltanext;
862 if (deltanext == I32_MAX)
863 is_inf = is_inf_internal = 1;
865 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
867 if (data && (data_fake.flags & SF_HAS_EVAL))
868 data->flags |= SF_HAS_EVAL;
870 data->whilem_c = data_fake.whilem_c;
871 if (flags & SCF_DO_STCLASS)
872 cl_or(pRExC_state, &accum, &this_class);
876 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
878 if (flags & SCF_DO_SUBSTR) {
879 data->pos_min += min1;
880 data->pos_delta += max1 - min1;
881 if (max1 != min1 || is_inf)
882 data->longest = &(data->longest_float);
885 delta += max1 - min1;
886 if (flags & SCF_DO_STCLASS_OR) {
887 cl_or(pRExC_state, data->start_class, &accum);
889 cl_and(data->start_class, &and_with);
890 flags &= ~SCF_DO_STCLASS;
893 else if (flags & SCF_DO_STCLASS_AND) {
895 cl_and(data->start_class, &accum);
896 flags &= ~SCF_DO_STCLASS;
899 /* Switch to OR mode: cache the old value of
900 * data->start_class */
901 StructCopy(data->start_class, &and_with,
902 struct regnode_charclass_class);
903 flags &= ~SCF_DO_STCLASS_AND;
904 StructCopy(&accum, data->start_class,
905 struct regnode_charclass_class);
906 flags |= SCF_DO_STCLASS_OR;
907 data->start_class->flags |= ANYOF_EOS;
911 else if (code == BRANCHJ) /* single branch is optimized. */
912 scan = NEXTOPER(NEXTOPER(scan));
913 else /* single branch is optimized. */
914 scan = NEXTOPER(scan);
917 else if (OP(scan) == EXACT) {
918 I32 l = STR_LEN(scan);
919 UV uc = *((U8*)STRING(scan));
921 U8 *s = (U8*)STRING(scan);
922 l = utf8_length(s, s + l);
923 uc = utf8_to_uvchr(s, NULL);
926 if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
927 /* The code below prefers earlier match for fixed
928 offset, later match for variable offset. */
929 if (data->last_end == -1) { /* Update the start info. */
930 data->last_start_min = data->pos_min;
931 data->last_start_max = is_inf
932 ? I32_MAX : data->pos_min + data->pos_delta;
934 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
935 data->last_end = data->pos_min + l;
936 data->pos_min += l; /* As in the first entry. */
937 data->flags &= ~SF_BEFORE_EOL;
939 if (flags & SCF_DO_STCLASS_AND) {
940 /* Check whether it is compatible with what we know already! */
944 (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
945 && !ANYOF_BITMAP_TEST(data->start_class, uc)
946 && (!(data->start_class->flags & ANYOF_FOLD)
947 || !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc])))
950 ANYOF_CLASS_ZERO(data->start_class);
951 ANYOF_BITMAP_ZERO(data->start_class);
953 ANYOF_BITMAP_SET(data->start_class, uc);
954 data->start_class->flags &= ~ANYOF_EOS;
956 data->start_class->flags &= ~ANYOF_UNICODE_ALL;
958 else if (flags & SCF_DO_STCLASS_OR) {
959 /* false positive possible if the class is case-folded */
961 ANYOF_BITMAP_SET(data->start_class, uc);
963 data->start_class->flags |= ANYOF_UNICODE_ALL;
964 data->start_class->flags &= ~ANYOF_EOS;
965 cl_and(data->start_class, &and_with);
967 flags &= ~SCF_DO_STCLASS;
969 else if (PL_regkind[(U8)OP(scan)] == EXACT) { /* But OP != EXACT! */
970 I32 l = STR_LEN(scan);
971 UV uc = *((U8*)STRING(scan));
973 /* Search for fixed substrings supports EXACT only. */
974 if (flags & SCF_DO_SUBSTR)
975 scan_commit(pRExC_state, data);
977 U8 *s = (U8 *)STRING(scan);
978 l = utf8_length(s, s + l);
979 uc = utf8_to_uvchr(s, NULL);
982 if (data && (flags & SCF_DO_SUBSTR))
984 if (flags & SCF_DO_STCLASS_AND) {
985 /* Check whether it is compatible with what we know already! */
989 (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
990 && !ANYOF_BITMAP_TEST(data->start_class, uc)
991 && !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc])))
993 ANYOF_CLASS_ZERO(data->start_class);
994 ANYOF_BITMAP_ZERO(data->start_class);
996 ANYOF_BITMAP_SET(data->start_class, uc);
997 data->start_class->flags &= ~ANYOF_EOS;
998 data->start_class->flags |= ANYOF_FOLD;
999 if (OP(scan) == EXACTFL)
1000 data->start_class->flags |= ANYOF_LOCALE;
1003 else if (flags & SCF_DO_STCLASS_OR) {
1004 if (data->start_class->flags & ANYOF_FOLD) {
1005 /* false positive possible if the class is case-folded.
1006 Assume that the locale settings are the same... */
1008 ANYOF_BITMAP_SET(data->start_class, uc);
1009 data->start_class->flags &= ~ANYOF_EOS;
1011 cl_and(data->start_class, &and_with);
1013 flags &= ~SCF_DO_STCLASS;
1015 else if (strchr((char*)PL_varies,OP(scan))) {
1016 I32 mincount, maxcount, minnext, deltanext, fl = 0;
1017 I32 f = flags, pos_before = 0;
1018 regnode *oscan = scan;
1019 struct regnode_charclass_class this_class;
1020 struct regnode_charclass_class *oclass = NULL;
1021 I32 next_is_eval = 0;
1023 switch (PL_regkind[(U8)OP(scan)]) {
1024 case WHILEM: /* End of (?:...)* . */
1025 scan = NEXTOPER(scan);
1028 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
1029 next = NEXTOPER(scan);
1030 if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
1032 maxcount = REG_INFTY;
1033 next = regnext(scan);
1034 scan = NEXTOPER(scan);
1038 if (flags & SCF_DO_SUBSTR)
1043 if (flags & SCF_DO_STCLASS) {
1045 maxcount = REG_INFTY;
1046 next = regnext(scan);
1047 scan = NEXTOPER(scan);
1050 is_inf = is_inf_internal = 1;
1051 scan = regnext(scan);
1052 if (flags & SCF_DO_SUBSTR) {
1053 scan_commit(pRExC_state, data); /* Cannot extend fixed substrings */
1054 data->longest = &(data->longest_float);
1056 goto optimize_curly_tail;
1058 mincount = ARG1(scan);
1059 maxcount = ARG2(scan);
1060 next = regnext(scan);
1061 if (OP(scan) == CURLYX) {
1062 I32 lp = (data ? *(data->last_closep) : 0);
1064 scan->flags = ((lp <= U8_MAX) ? lp : U8_MAX);
1066 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
1067 next_is_eval = (OP(scan) == EVAL);
1069 if (flags & SCF_DO_SUBSTR) {
1070 if (mincount == 0) scan_commit(pRExC_state,data); /* Cannot extend fixed substrings */
1071 pos_before = data->pos_min;
1075 data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
1077 data->flags |= SF_IS_INF;
1079 if (flags & SCF_DO_STCLASS) {
1080 cl_init(pRExC_state, &this_class);
1081 oclass = data->start_class;
1082 data->start_class = &this_class;
1083 f |= SCF_DO_STCLASS_AND;
1084 f &= ~SCF_DO_STCLASS_OR;
1086 /* These are the cases when once a subexpression
1087 fails at a particular position, it cannot succeed
1088 even after backtracking at the enclosing scope.
1090 XXXX what if minimal match and we are at the
1091 initial run of {n,m}? */
1092 if ((mincount != maxcount - 1) && (maxcount != REG_INFTY))
1093 f &= ~SCF_WHILEM_VISITED_POS;
1095 /* This will finish on WHILEM, setting scan, or on NULL: */
1096 minnext = study_chunk(pRExC_state, &scan, &deltanext, last, data,
1098 ? (f & ~SCF_DO_SUBSTR) : f);
1100 if (flags & SCF_DO_STCLASS)
1101 data->start_class = oclass;
1102 if (mincount == 0 || minnext == 0) {
1103 if (flags & SCF_DO_STCLASS_OR) {
1104 cl_or(pRExC_state, data->start_class, &this_class);
1106 else if (flags & SCF_DO_STCLASS_AND) {
1107 /* Switch to OR mode: cache the old value of
1108 * data->start_class */
1109 StructCopy(data->start_class, &and_with,
1110 struct regnode_charclass_class);
1111 flags &= ~SCF_DO_STCLASS_AND;
1112 StructCopy(&this_class, data->start_class,
1113 struct regnode_charclass_class);
1114 flags |= SCF_DO_STCLASS_OR;
1115 data->start_class->flags |= ANYOF_EOS;
1117 } else { /* Non-zero len */
1118 if (flags & SCF_DO_STCLASS_OR) {
1119 cl_or(pRExC_state, data->start_class, &this_class);
1120 cl_and(data->start_class, &and_with);
1122 else if (flags & SCF_DO_STCLASS_AND)
1123 cl_and(data->start_class, &this_class);
1124 flags &= ~SCF_DO_STCLASS;
1126 if (!scan) /* It was not CURLYX, but CURLY. */
1128 if (ckWARN(WARN_REGEXP)
1129 /* ? quantifier ok, except for (?{ ... }) */
1130 && (next_is_eval || !(mincount == 0 && maxcount == 1))
1131 && (minnext == 0) && (deltanext == 0)
1132 && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
1133 && maxcount <= REG_INFTY/3) /* Complement check for big count */
1136 "Quantifier unexpected on zero-length expression");
1139 min += minnext * mincount;
1140 is_inf_internal |= ((maxcount == REG_INFTY
1141 && (minnext + deltanext) > 0)
1142 || deltanext == I32_MAX);
1143 is_inf |= is_inf_internal;
1144 delta += (minnext + deltanext) * maxcount - minnext * mincount;
1146 /* Try powerful optimization CURLYX => CURLYN. */
1147 if ( OP(oscan) == CURLYX && data
1148 && data->flags & SF_IN_PAR
1149 && !(data->flags & SF_HAS_EVAL)
1150 && !deltanext && minnext == 1 ) {
1151 /* Try to optimize to CURLYN. */
1152 regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
1153 regnode *nxt1 = nxt;
1160 if (!strchr((char*)PL_simple,OP(nxt))
1161 && !(PL_regkind[(U8)OP(nxt)] == EXACT
1162 && STR_LEN(nxt) == 1))
1168 if (OP(nxt) != CLOSE)
1170 /* Now we know that nxt2 is the only contents: */
1171 oscan->flags = ARG(nxt);
1173 OP(nxt1) = NOTHING; /* was OPEN. */
1175 OP(nxt1 + 1) = OPTIMIZED; /* was count. */
1176 NEXT_OFF(nxt1+ 1) = 0; /* just for consistancy. */
1177 NEXT_OFF(nxt2) = 0; /* just for consistancy with CURLY. */
1178 OP(nxt) = OPTIMIZED; /* was CLOSE. */
1179 OP(nxt + 1) = OPTIMIZED; /* was count. */
1180 NEXT_OFF(nxt+ 1) = 0; /* just for consistancy. */
1185 /* Try optimization CURLYX => CURLYM. */
1186 if ( OP(oscan) == CURLYX && data
1187 && !(data->flags & SF_HAS_PAR)
1188 && !(data->flags & SF_HAS_EVAL)
1190 /* XXXX How to optimize if data == 0? */
1191 /* Optimize to a simpler form. */
1192 regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
1196 while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
1197 && (OP(nxt2) != WHILEM))
1199 OP(nxt2) = SUCCEED; /* Whas WHILEM */
1200 /* Need to optimize away parenths. */
1201 if (data->flags & SF_IN_PAR) {
1202 /* Set the parenth number. */
1203 regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
1205 if (OP(nxt) != CLOSE)
1206 FAIL("Panic opt close");
1207 oscan->flags = ARG(nxt);
1208 OP(nxt1) = OPTIMIZED; /* was OPEN. */
1209 OP(nxt) = OPTIMIZED; /* was CLOSE. */
1211 OP(nxt1 + 1) = OPTIMIZED; /* was count. */
1212 OP(nxt + 1) = OPTIMIZED; /* was count. */
1213 NEXT_OFF(nxt1 + 1) = 0; /* just for consistancy. */
1214 NEXT_OFF(nxt + 1) = 0; /* just for consistancy. */
1217 while ( nxt1 && (OP(nxt1) != WHILEM)) {
1218 regnode *nnxt = regnext(nxt1);
1221 if (reg_off_by_arg[OP(nxt1)])
1222 ARG_SET(nxt1, nxt2 - nxt1);
1223 else if (nxt2 - nxt1 < U16_MAX)
1224 NEXT_OFF(nxt1) = nxt2 - nxt1;
1226 OP(nxt) = NOTHING; /* Cannot beautify */
1231 /* Optimize again: */
1232 study_chunk(pRExC_state, &nxt1, &deltanext, nxt,
1238 else if ((OP(oscan) == CURLYX)
1239 && (flags & SCF_WHILEM_VISITED_POS)
1240 /* See the comment on a similar expression above.
1241 However, this time it not a subexpression
1242 we care about, but the expression itself. */
1243 && (maxcount == REG_INFTY)
1244 && data && ++data->whilem_c < 16) {
1245 /* This stays as CURLYX, we can put the count/of pair. */
1246 /* Find WHILEM (as in regexec.c) */
1247 regnode *nxt = oscan + NEXT_OFF(oscan);
1249 if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
1251 PREVOPER(nxt)->flags = data->whilem_c
1252 | (RExC_whilem_seen << 4); /* On WHILEM */
1254 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
1256 if (flags & SCF_DO_SUBSTR) {
1257 SV *last_str = Nullsv;
1258 int counted = mincount != 0;
1260 if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
1261 #if defined(SPARC64_GCC_WORKAROUND)
1267 if (pos_before >= data->last_start_min)
1270 b = data->last_start_min;
1273 s = SvPV(data->last_found, l);
1274 old = b - data->last_start_min;
1277 I32 b = pos_before >= data->last_start_min
1278 ? pos_before : data->last_start_min;
1280 char *s = SvPV(data->last_found, l);
1281 I32 old = b - data->last_start_min;
1285 old = utf8_hop((U8*)s, old) - (U8*)s;
1288 /* Get the added string: */
1289 last_str = newSVpvn(s + old, l);
1290 if (deltanext == 0 && pos_before == b) {
1291 /* What was added is a constant string */
1293 SvGROW(last_str, (mincount * l) + 1);
1294 repeatcpy(SvPVX(last_str) + l,
1295 SvPVX(last_str), l, mincount - 1);
1296 SvCUR(last_str) *= mincount;
1297 /* Add additional parts. */
1298 SvCUR_set(data->last_found,
1299 SvCUR(data->last_found) - l);
1300 sv_catsv(data->last_found, last_str);
1301 data->last_end += l * (mincount - 1);
1304 /* start offset must point into the last copy */
1305 data->last_start_min += minnext * (mincount - 1);
1306 data->last_start_max += is_inf ? 0 : (maxcount - 1)
1307 * (minnext + data->pos_delta);
1310 /* It is counted once already... */
1311 data->pos_min += minnext * (mincount - counted);
1312 data->pos_delta += - counted * deltanext +
1313 (minnext + deltanext) * maxcount - minnext * mincount;
1314 if (mincount != maxcount) {
1315 /* Cannot extend fixed substrings found inside
1317 scan_commit(pRExC_state,data);
1318 if (mincount && last_str) {
1319 sv_setsv(data->last_found, last_str);
1320 data->last_end = data->pos_min;
1321 data->last_start_min =
1322 data->pos_min - CHR_SVLEN(last_str);
1323 data->last_start_max = is_inf
1325 : data->pos_min + data->pos_delta
1326 - CHR_SVLEN(last_str);
1328 data->longest = &(data->longest_float);
1330 SvREFCNT_dec(last_str);
1332 if (data && (fl & SF_HAS_EVAL))
1333 data->flags |= SF_HAS_EVAL;
1334 optimize_curly_tail:
1335 if (OP(oscan) != CURLYX) {
1336 while (PL_regkind[(U8)OP(next = regnext(oscan))] == NOTHING
1338 NEXT_OFF(oscan) += NEXT_OFF(next);
1341 default: /* REF and CLUMP only? */
1342 if (flags & SCF_DO_SUBSTR) {
1343 scan_commit(pRExC_state,data); /* Cannot expect anything... */
1344 data->longest = &(data->longest_float);
1346 is_inf = is_inf_internal = 1;
1347 if (flags & SCF_DO_STCLASS_OR)
1348 cl_anything(pRExC_state, data->start_class);
1349 flags &= ~SCF_DO_STCLASS;
1353 else if (strchr((char*)PL_simple,OP(scan))) {
1356 if (flags & SCF_DO_SUBSTR) {
1357 scan_commit(pRExC_state,data);
1361 if (flags & SCF_DO_STCLASS) {
1362 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
1364 /* Some of the logic below assumes that switching
1365 locale on will only add false positives. */
1366 switch (PL_regkind[(U8)OP(scan)]) {
1370 /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
1371 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
1372 cl_anything(pRExC_state, data->start_class);
1375 if (OP(scan) == SANY)
1377 if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
1378 value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
1379 || (data->start_class->flags & ANYOF_CLASS));
1380 cl_anything(pRExC_state, data->start_class);
1382 if (flags & SCF_DO_STCLASS_AND || !value)
1383 ANYOF_BITMAP_CLEAR(data->start_class,'\n');
1386 if (flags & SCF_DO_STCLASS_AND)
1387 cl_and(data->start_class,
1388 (struct regnode_charclass_class*)scan);
1390 cl_or(pRExC_state, data->start_class,
1391 (struct regnode_charclass_class*)scan);
1394 if (flags & SCF_DO_STCLASS_AND) {
1395 if (!(data->start_class->flags & ANYOF_LOCALE)) {
1396 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
1397 for (value = 0; value < 256; value++)
1398 if (!isALNUM(value))
1399 ANYOF_BITMAP_CLEAR(data->start_class, value);
1403 if (data->start_class->flags & ANYOF_LOCALE)
1404 ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
1406 for (value = 0; value < 256; value++)
1408 ANYOF_BITMAP_SET(data->start_class, value);
1413 if (flags & SCF_DO_STCLASS_AND) {
1414 if (data->start_class->flags & ANYOF_LOCALE)
1415 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
1418 ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
1419 data->start_class->flags |= ANYOF_LOCALE;
1423 if (flags & SCF_DO_STCLASS_AND) {
1424 if (!(data->start_class->flags & ANYOF_LOCALE)) {
1425 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
1426 for (value = 0; value < 256; value++)
1428 ANYOF_BITMAP_CLEAR(data->start_class, value);
1432 if (data->start_class->flags & ANYOF_LOCALE)
1433 ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
1435 for (value = 0; value < 256; value++)
1436 if (!isALNUM(value))
1437 ANYOF_BITMAP_SET(data->start_class, value);
1442 if (flags & SCF_DO_STCLASS_AND) {
1443 if (data->start_class->flags & ANYOF_LOCALE)
1444 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
1447 data->start_class->flags |= ANYOF_LOCALE;
1448 ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
1452 if (flags & SCF_DO_STCLASS_AND) {
1453 if (!(data->start_class->flags & ANYOF_LOCALE)) {
1454 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
1455 for (value = 0; value < 256; value++)
1456 if (!isSPACE(value))
1457 ANYOF_BITMAP_CLEAR(data->start_class, value);
1461 if (data->start_class->flags & ANYOF_LOCALE)
1462 ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
1464 for (value = 0; value < 256; value++)
1466 ANYOF_BITMAP_SET(data->start_class, value);
1471 if (flags & SCF_DO_STCLASS_AND) {
1472 if (data->start_class->flags & ANYOF_LOCALE)
1473 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
1476 data->start_class->flags |= ANYOF_LOCALE;
1477 ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
1481 if (flags & SCF_DO_STCLASS_AND) {
1482 if (!(data->start_class->flags & ANYOF_LOCALE)) {
1483 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
1484 for (value = 0; value < 256; value++)
1486 ANYOF_BITMAP_CLEAR(data->start_class, value);
1490 if (data->start_class->flags & ANYOF_LOCALE)
1491 ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
1493 for (value = 0; value < 256; value++)
1494 if (!isSPACE(value))
1495 ANYOF_BITMAP_SET(data->start_class, value);
1500 if (flags & SCF_DO_STCLASS_AND) {
1501 if (data->start_class->flags & ANYOF_LOCALE) {
1502 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
1503 for (value = 0; value < 256; value++)
1504 if (!isSPACE(value))
1505 ANYOF_BITMAP_CLEAR(data->start_class, value);
1509 data->start_class->flags |= ANYOF_LOCALE;
1510 ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
1514 if (flags & SCF_DO_STCLASS_AND) {
1515 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT);
1516 for (value = 0; value < 256; value++)
1517 if (!isDIGIT(value))
1518 ANYOF_BITMAP_CLEAR(data->start_class, value);
1521 if (data->start_class->flags & ANYOF_LOCALE)
1522 ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT);
1524 for (value = 0; value < 256; value++)
1526 ANYOF_BITMAP_SET(data->start_class, value);
1531 if (flags & SCF_DO_STCLASS_AND) {
1532 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT);
1533 for (value = 0; value < 256; value++)
1535 ANYOF_BITMAP_CLEAR(data->start_class, value);
1538 if (data->start_class->flags & ANYOF_LOCALE)
1539 ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT);
1541 for (value = 0; value < 256; value++)
1542 if (!isDIGIT(value))
1543 ANYOF_BITMAP_SET(data->start_class, value);
1548 if (flags & SCF_DO_STCLASS_OR)
1549 cl_and(data->start_class, &and_with);
1550 flags &= ~SCF_DO_STCLASS;
1553 else if (PL_regkind[(U8)OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
1554 data->flags |= (OP(scan) == MEOL
1558 else if ( PL_regkind[(U8)OP(scan)] == BRANCHJ
1559 /* Lookbehind, or need to calculate parens/evals/stclass: */
1560 && (scan->flags || data || (flags & SCF_DO_STCLASS))
1561 && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
1562 /* Lookahead/lookbehind */
1563 I32 deltanext, minnext, fake = 0;
1565 struct regnode_charclass_class intrnl;
1568 data_fake.flags = 0;
1570 data_fake.whilem_c = data->whilem_c;
1571 data_fake.last_closep = data->last_closep;
1574 data_fake.last_closep = &fake;
1575 if ( flags & SCF_DO_STCLASS && !scan->flags
1576 && OP(scan) == IFMATCH ) { /* Lookahead */
1577 cl_init(pRExC_state, &intrnl);
1578 data_fake.start_class = &intrnl;
1579 f |= SCF_DO_STCLASS_AND;
1581 if (flags & SCF_WHILEM_VISITED_POS)
1582 f |= SCF_WHILEM_VISITED_POS;
1583 next = regnext(scan);
1584 nscan = NEXTOPER(NEXTOPER(scan));
1585 minnext = study_chunk(pRExC_state, &nscan, &deltanext, last, &data_fake, f);
1588 vFAIL("Variable length lookbehind not implemented");
1590 else if (minnext > U8_MAX) {
1591 vFAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
1593 scan->flags = minnext;
1595 if (data && data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
1597 if (data && (data_fake.flags & SF_HAS_EVAL))
1598 data->flags |= SF_HAS_EVAL;
1600 data->whilem_c = data_fake.whilem_c;
1601 if (f & SCF_DO_STCLASS_AND) {
1602 int was = (data->start_class->flags & ANYOF_EOS);
1604 cl_and(data->start_class, &intrnl);
1606 data->start_class->flags |= ANYOF_EOS;
1609 else if (OP(scan) == OPEN) {
1612 else if (OP(scan) == CLOSE) {
1613 if (ARG(scan) == is_par) {
1614 next = regnext(scan);
1616 if ( next && (OP(next) != WHILEM) && next < last)
1617 is_par = 0; /* Disable optimization */
1620 *(data->last_closep) = ARG(scan);
1622 else if (OP(scan) == EVAL) {
1624 data->flags |= SF_HAS_EVAL;
1626 else if (OP(scan) == LOGICAL && scan->flags == 2) { /* Embedded follows */
1627 if (flags & SCF_DO_SUBSTR) {
1628 scan_commit(pRExC_state,data);
1629 data->longest = &(data->longest_float);
1631 is_inf = is_inf_internal = 1;
1632 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
1633 cl_anything(pRExC_state, data->start_class);
1634 flags &= ~SCF_DO_STCLASS;
1636 /* Else: zero-length, ignore. */
1637 scan = regnext(scan);
1642 *deltap = is_inf_internal ? I32_MAX : delta;
1643 if (flags & SCF_DO_SUBSTR && is_inf)
1644 data->pos_delta = I32_MAX - data->pos_min;
1645 if (is_par > U8_MAX)
1647 if (is_par && pars==1 && data) {
1648 data->flags |= SF_IN_PAR;
1649 data->flags &= ~SF_HAS_PAR;
1651 else if (pars && data) {
1652 data->flags |= SF_HAS_PAR;
1653 data->flags &= ~SF_IN_PAR;
1655 if (flags & SCF_DO_STCLASS_OR)
1656 cl_and(data->start_class, &and_with);
1661 S_add_data(pTHX_ RExC_state_t *pRExC_state, I32 n, char *s)
1663 if (RExC_rx->data) {
1664 Renewc(RExC_rx->data,
1665 sizeof(*RExC_rx->data) + sizeof(void*) * (RExC_rx->data->count + n - 1),
1666 char, struct reg_data);
1667 Renew(RExC_rx->data->what, RExC_rx->data->count + n, U8);
1668 RExC_rx->data->count += n;
1671 Newc(1207, RExC_rx->data, sizeof(*RExC_rx->data) + sizeof(void*) * (n - 1),
1672 char, struct reg_data);
1673 New(1208, RExC_rx->data->what, n, U8);
1674 RExC_rx->data->count = n;
1676 Copy(s, RExC_rx->data->what + RExC_rx->data->count - n, n, U8);
1677 return RExC_rx->data->count - n;
1681 Perl_reginitcolors(pTHX)
1684 char *s = PerlEnv_getenv("PERL_RE_COLORS");
1687 PL_colors[0] = s = savepv(s);
1689 s = strchr(s, '\t');
1695 PL_colors[i] = s = "";
1699 PL_colors[i++] = "";
1706 - pregcomp - compile a regular expression into internal code
1708 * We can't allocate space until we know how big the compiled form will be,
1709 * but we can't compile it (and thus know how big it is) until we've got a
1710 * place to put the code. So we cheat: we compile it twice, once with code
1711 * generation turned off and size counting turned on, and once "for real".
1712 * This also means that we don't allocate space until we are sure that the
1713 * thing really will compile successfully, and we never have to move the
1714 * code and thus invalidate pointers into it. (Note that it has to be in
1715 * one piece because free() must be able to free it all.) [NB: not true in perl]
1717 * Beware that the optimization-preparation code in here knows about some
1718 * of the structure of the compiled regexp. [I'll say.]
1721 Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
1731 RExC_state_t RExC_state;
1732 RExC_state_t *pRExC_state = &RExC_state;
1735 FAIL("NULL regexp argument");
1737 RExC_utf8 = pm->op_pmdynflags & PMdf_CMP_UTF8;
1741 if (!PL_colorset) reginitcolors();
1742 PerlIO_printf(Perl_debug_log, "%sCompiling REx%s `%s%*s%s'\n",
1743 PL_colors[4],PL_colors[5],PL_colors[0],
1744 (int)(xend - exp), RExC_precomp, PL_colors[1]);
1746 RExC_flags16 = pm->op_pmflags;
1750 RExC_seen_zerolen = *exp == '^' ? -1 : 0;
1751 RExC_seen_evals = 0;
1754 /* First pass: determine size, legality. */
1761 RExC_emit = &PL_regdummy;
1762 RExC_whilem_seen = 0;
1763 #if 0 /* REGC() is (currently) a NOP at the first pass.
1764 * Clever compilers notice this and complain. --jhi */
1765 REGC((U8)REG_MAGIC, (char*)RExC_emit);
1767 if (reg(pRExC_state, 0, &flags) == NULL) {
1768 RExC_precomp = Nullch;
1771 DEBUG_r(PerlIO_printf(Perl_debug_log, "size %"IVdf" ", (IV)RExC_size));
1773 /* Small enough for pointer-storage convention?
1774 If extralen==0, this means that we will not need long jumps. */
1775 if (RExC_size >= 0x10000L && RExC_extralen)
1776 RExC_size += RExC_extralen;
1779 if (RExC_whilem_seen > 15)
1780 RExC_whilem_seen = 15;
1782 /* Allocate space and initialize. */
1783 Newc(1001, r, sizeof(regexp) + (unsigned)RExC_size * sizeof(regnode),
1786 FAIL("Regexp out of space");
1789 /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
1790 Zero(r, sizeof(regexp) + (unsigned)RExC_size * sizeof(regnode), char);
1793 r->prelen = xend - exp;
1794 r->precomp = savepvn(RExC_precomp, r->prelen);
1796 r->reganch = pm->op_pmflags & PMf_COMPILETIME;
1797 r->nparens = RExC_npar - 1; /* set early to validate backrefs */
1799 r->substrs = 0; /* Useful during FAIL. */
1800 r->startp = 0; /* Useful during FAIL. */
1801 r->endp = 0; /* Useful during FAIL. */
1803 Newz(1304, r->offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
1805 r->offsets[0] = RExC_size;
1807 DEBUG_r(PerlIO_printf(Perl_debug_log,
1808 "%s %"UVuf" bytes for offset annotations.\n",
1809 r->offsets ? "Got" : "Couldn't get",
1810 (UV)((2*RExC_size+1) * sizeof(U32))));
1814 /* Second pass: emit code. */
1815 RExC_flags16 = pm->op_pmflags; /* don't let top level (?i) bleed */
1820 RExC_emit_start = r->program;
1821 RExC_emit = r->program;
1822 /* Store the count of eval-groups for security checks: */
1823 RExC_emit->next_off = ((RExC_seen_evals > U16_MAX) ? U16_MAX : RExC_seen_evals);
1824 REGC((U8)REG_MAGIC, (char*) RExC_emit++);
1826 if (reg(pRExC_state, 0, &flags) == NULL)
1829 /* Dig out information for optimizations. */
1830 r->reganch = pm->op_pmflags & PMf_COMPILETIME; /* Again? */
1831 pm->op_pmflags = RExC_flags16;
1833 r->reganch |= ROPT_UTF8; /* Unicode in it? */
1834 r->regstclass = NULL;
1835 if (RExC_naughty >= 10) /* Probably an expensive pattern. */
1836 r->reganch |= ROPT_NAUGHTY;
1837 scan = r->program + 1; /* First BRANCH. */
1839 /* XXXX To minimize changes to RE engine we always allocate
1840 3-units-long substrs field. */
1841 Newz(1004, r->substrs, 1, struct reg_substr_data);
1843 StructCopy(&zero_scan_data, &data, scan_data_t);
1844 /* XXXX Should not we check for something else? Usually it is OPEN1... */
1845 if (OP(scan) != BRANCH) { /* Only one top-level choice. */
1847 STRLEN longest_float_length, longest_fixed_length;
1848 struct regnode_charclass_class ch_class;
1853 /* Skip introductions and multiplicators >= 1. */
1854 while ((OP(first) == OPEN && (sawopen = 1)) ||
1855 /* An OR of *one* alternative - should not happen now. */
1856 (OP(first) == BRANCH && OP(regnext(first)) != BRANCH) ||
1857 (OP(first) == PLUS) ||
1858 (OP(first) == MINMOD) ||
1859 /* An {n,m} with n>0 */
1860 (PL_regkind[(U8)OP(first)] == CURLY && ARG1(first) > 0) ) {
1861 if (OP(first) == PLUS)
1864 first += regarglen[(U8)OP(first)];
1865 first = NEXTOPER(first);
1868 /* Starting-point info. */
1870 if (PL_regkind[(U8)OP(first)] == EXACT) {
1871 if (OP(first) == EXACT)
1872 ; /* Empty, get anchored substr later. */
1873 else if ((OP(first) == EXACTF || OP(first) == EXACTFL))
1874 r->regstclass = first;
1876 else if (strchr((char*)PL_simple,OP(first)))
1877 r->regstclass = first;
1878 else if (PL_regkind[(U8)OP(first)] == BOUND ||
1879 PL_regkind[(U8)OP(first)] == NBOUND)
1880 r->regstclass = first;
1881 else if (PL_regkind[(U8)OP(first)] == BOL) {
1882 r->reganch |= (OP(first) == MBOL
1884 : (OP(first) == SBOL
1887 first = NEXTOPER(first);
1890 else if (OP(first) == GPOS) {
1891 r->reganch |= ROPT_ANCH_GPOS;
1892 first = NEXTOPER(first);
1895 else if (!sawopen && (OP(first) == STAR &&
1896 PL_regkind[(U8)OP(NEXTOPER(first))] == REG_ANY) &&
1897 !(r->reganch & ROPT_ANCH) )
1899 /* turn .* into ^.* with an implied $*=1 */
1900 int type = OP(NEXTOPER(first));
1902 if (type == REG_ANY)
1903 type = ROPT_ANCH_MBOL;
1905 type = ROPT_ANCH_SBOL;
1907 r->reganch |= type | ROPT_IMPLICIT;
1908 first = NEXTOPER(first);
1911 if (sawplus && (!sawopen || !RExC_sawback)
1912 && !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */
1913 /* x+ must match at the 1st pos of run of x's */
1914 r->reganch |= ROPT_SKIP;
1916 /* Scan is after the zeroth branch, first is atomic matcher. */
1917 DEBUG_r(PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
1918 (IV)(first - scan + 1)));
1920 * If there's something expensive in the r.e., find the
1921 * longest literal string that must appear and make it the
1922 * regmust. Resolve ties in favor of later strings, since
1923 * the regstart check works with the beginning of the r.e.
1924 * and avoiding duplication strengthens checking. Not a
1925 * strong reason, but sufficient in the absence of others.
1926 * [Now we resolve ties in favor of the earlier string if
1927 * it happens that c_offset_min has been invalidated, since the
1928 * earlier string may buy us something the later one won't.]
1932 data.longest_fixed = newSVpvn("",0);
1933 data.longest_float = newSVpvn("",0);
1934 data.last_found = newSVpvn("",0);
1935 data.longest = &(data.longest_fixed);
1937 if (!r->regstclass) {
1938 cl_init(pRExC_state, &ch_class);
1939 data.start_class = &ch_class;
1940 stclass_flag = SCF_DO_STCLASS_AND;
1941 } else /* XXXX Check for BOUND? */
1943 data.last_closep = &last_close;
1945 minlen = study_chunk(pRExC_state, &first, &fake, scan + RExC_size, /* Up to end */
1946 &data, SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag);
1947 if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
1948 && data.last_start_min == 0 && data.last_end > 0
1949 && !RExC_seen_zerolen
1950 && (!(RExC_seen & REG_SEEN_GPOS) || (r->reganch & ROPT_ANCH_GPOS)))
1951 r->reganch |= ROPT_CHECK_ALL;
1952 scan_commit(pRExC_state, &data);
1953 SvREFCNT_dec(data.last_found);
1955 longest_float_length = CHR_SVLEN(data.longest_float);
1956 if (longest_float_length
1957 || (data.flags & SF_FL_BEFORE_EOL
1958 && (!(data.flags & SF_FL_BEFORE_MEOL)
1959 || (RExC_flags16 & PMf_MULTILINE)))) {
1962 if (SvCUR(data.longest_fixed) /* ok to leave SvCUR */
1963 && data.offset_fixed == data.offset_float_min
1964 && SvCUR(data.longest_fixed) == SvCUR(data.longest_float))
1965 goto remove_float; /* As in (a)+. */
1967 r->float_substr = data.longest_float;
1968 r->float_min_offset = data.offset_float_min;
1969 r->float_max_offset = data.offset_float_max;
1970 t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
1971 && (!(data.flags & SF_FL_BEFORE_MEOL)
1972 || (RExC_flags16 & PMf_MULTILINE)));
1973 fbm_compile(r->float_substr, t ? FBMcf_TAIL : 0);
1977 r->float_substr = Nullsv;
1978 SvREFCNT_dec(data.longest_float);
1979 longest_float_length = 0;
1982 longest_fixed_length = CHR_SVLEN(data.longest_fixed);
1983 if (longest_fixed_length
1984 || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
1985 && (!(data.flags & SF_FIX_BEFORE_MEOL)
1986 || (RExC_flags16 & PMf_MULTILINE)))) {
1989 r->anchored_substr = data.longest_fixed;
1990 r->anchored_offset = data.offset_fixed;
1991 t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
1992 && (!(data.flags & SF_FIX_BEFORE_MEOL)
1993 || (RExC_flags16 & PMf_MULTILINE)));
1994 fbm_compile(r->anchored_substr, t ? FBMcf_TAIL : 0);
1997 r->anchored_substr = Nullsv;
1998 SvREFCNT_dec(data.longest_fixed);
1999 longest_fixed_length = 0;
2002 && (OP(r->regstclass) == REG_ANY || OP(r->regstclass) == SANY))
2003 r->regstclass = NULL;
2004 if ((!r->anchored_substr || r->anchored_offset) && stclass_flag
2005 && !(data.start_class->flags & ANYOF_EOS)
2006 && !cl_is_anything(data.start_class)) {
2007 I32 n = add_data(pRExC_state, 1, "f");
2009 New(1006, RExC_rx->data->data[n], 1,
2010 struct regnode_charclass_class);
2011 StructCopy(data.start_class,
2012 (struct regnode_charclass_class*)RExC_rx->data->data[n],
2013 struct regnode_charclass_class);
2014 r->regstclass = (regnode*)RExC_rx->data->data[n];
2015 r->reganch &= ~ROPT_SKIP; /* Used in find_byclass(). */
2016 PL_regdata = r->data; /* for regprop() */
2017 DEBUG_r({ SV *sv = sv_newmortal();
2018 regprop(sv, (regnode*)data.start_class);
2019 PerlIO_printf(Perl_debug_log,
2020 "synthetic stclass `%s'.\n",
2024 /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
2025 if (longest_fixed_length > longest_float_length) {
2026 r->check_substr = r->anchored_substr;
2027 r->check_offset_min = r->check_offset_max = r->anchored_offset;
2028 if (r->reganch & ROPT_ANCH_SINGLE)
2029 r->reganch |= ROPT_NOSCAN;
2032 r->check_substr = r->float_substr;
2033 r->check_offset_min = data.offset_float_min;
2034 r->check_offset_max = data.offset_float_max;
2036 /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
2037 This should be changed ASAP! */
2038 if (r->check_substr && !(r->reganch & ROPT_ANCH_GPOS)) {
2039 r->reganch |= RE_USE_INTUIT;
2040 if (SvTAIL(r->check_substr))
2041 r->reganch |= RE_INTUIT_TAIL;
2045 /* Several toplevels. Best we can is to set minlen. */
2047 struct regnode_charclass_class ch_class;
2050 DEBUG_r(PerlIO_printf(Perl_debug_log, "\n"));
2051 scan = r->program + 1;
2052 cl_init(pRExC_state, &ch_class);
2053 data.start_class = &ch_class;
2054 data.last_closep = &last_close;
2055 minlen = study_chunk(pRExC_state, &scan, &fake, scan + RExC_size, &data, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS);
2056 r->check_substr = r->anchored_substr = r->float_substr = Nullsv;
2057 if (!(data.start_class->flags & ANYOF_EOS)
2058 && !cl_is_anything(data.start_class)) {
2059 I32 n = add_data(pRExC_state, 1, "f");
2061 New(1006, RExC_rx->data->data[n], 1,
2062 struct regnode_charclass_class);
2063 StructCopy(data.start_class,
2064 (struct regnode_charclass_class*)RExC_rx->data->data[n],
2065 struct regnode_charclass_class);
2066 r->regstclass = (regnode*)RExC_rx->data->data[n];
2067 r->reganch &= ~ROPT_SKIP; /* Used in find_byclass(). */
2068 DEBUG_r({ SV* sv = sv_newmortal();
2069 regprop(sv, (regnode*)data.start_class);
2070 PerlIO_printf(Perl_debug_log,
2071 "synthetic stclass `%s'.\n",
2077 if (RExC_seen & REG_SEEN_GPOS)
2078 r->reganch |= ROPT_GPOS_SEEN;
2079 if (RExC_seen & REG_SEEN_LOOKBEHIND)
2080 r->reganch |= ROPT_LOOKBEHIND_SEEN;
2081 if (RExC_seen & REG_SEEN_EVAL)
2082 r->reganch |= ROPT_EVAL_SEEN;
2083 if (RExC_seen & REG_SEEN_CANY)
2084 r->reganch |= ROPT_CANY_SEEN;
2085 Newz(1002, r->startp, RExC_npar, I32);
2086 Newz(1002, r->endp, RExC_npar, I32);
2087 PL_regdata = r->data; /* for regprop() */
2088 DEBUG_r(regdump(r));
2093 - reg - regular expression, i.e. main body or parenthesized thing
2095 * Caller must absorb opening parenthesis.
2097 * Combining parenthesis handling with the base level of regular expression
2098 * is a trifle forced, but the need to tie the tails of the branches to what
2099 * follows makes it hard to avoid.
2102 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp)
2103 /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
2105 register regnode *ret; /* Will be the head of the group. */
2106 register regnode *br;
2107 register regnode *lastbr;
2108 register regnode *ender = 0;
2109 register I32 parno = 0;
2110 I32 flags, oregflags = RExC_flags16, have_branch = 0, open = 0;
2112 /* for (?g), (?gc), and (?o) warnings; warning
2113 about (?c) will warn about (?g) -- japhy */
2115 I32 wastedflags = 0x00,
2118 wasted_gc = 0x02 | 0x04,
2121 char * parse_start = RExC_parse; /* MJD */
2122 char *oregcomp_parse = RExC_parse;
2125 *flagp = 0; /* Tentatively. */
2128 /* Make an OPEN node, if parenthesized. */
2130 if (*RExC_parse == '?') { /* (?...) */
2131 U16 posflags = 0, negflags = 0;
2132 U16 *flagsp = &posflags;
2134 char *seqstart = RExC_parse;
2137 paren = *RExC_parse++;
2138 ret = NULL; /* For look-ahead/behind. */
2140 case '<': /* (?<...) */
2141 RExC_seen |= REG_SEEN_LOOKBEHIND;
2142 if (*RExC_parse == '!')
2144 if (*RExC_parse != '=' && *RExC_parse != '!')
2147 case '=': /* (?=...) */
2148 case '!': /* (?!...) */
2149 RExC_seen_zerolen++;
2150 case ':': /* (?:...) */
2151 case '>': /* (?>...) */
2153 case '$': /* (?$...) */
2154 case '@': /* (?@...) */
2155 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
2157 case '#': /* (?#...) */
2158 while (*RExC_parse && *RExC_parse != ')')
2160 if (*RExC_parse != ')')
2161 FAIL("Sequence (?#... not terminated");
2162 nextchar(pRExC_state);
2165 case 'p': /* (?p...) */
2166 if (SIZE_ONLY && ckWARN2(WARN_DEPRECATED, WARN_REGEXP))
2167 vWARNdep(RExC_parse, "(?p{}) is deprecated - use (??{})");
2169 case '?': /* (??...) */
2171 paren = *RExC_parse++;
2173 case '{': /* (?{...}) */
2175 I32 count = 1, n = 0;
2177 char *s = RExC_parse;
2179 OP_4tree *sop, *rop;
2181 RExC_seen_zerolen++;
2182 RExC_seen |= REG_SEEN_EVAL;
2183 while (count && (c = *RExC_parse)) {
2184 if (c == '\\' && RExC_parse[1])
2192 if (*RExC_parse != ')')
2195 vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
2200 if (RExC_parse - 1 - s)
2201 sv = newSVpvn(s, RExC_parse - 1 - s);
2203 sv = newSVpvn("", 0);
2206 Perl_save_re_context(aTHX);
2207 rop = sv_compile_2op(sv, &sop, "re", &av);
2208 sop->op_private |= OPpREFCOUNTED;
2209 /* re_dup will OpREFCNT_inc */
2210 OpREFCNT_set(sop, 1);
2213 n = add_data(pRExC_state, 3, "nop");
2214 RExC_rx->data->data[n] = (void*)rop;
2215 RExC_rx->data->data[n+1] = (void*)sop;
2216 RExC_rx->data->data[n+2] = (void*)av;
2219 else { /* First pass */
2220 if (PL_reginterp_cnt < ++RExC_seen_evals
2221 && PL_curcop != &PL_compiling)
2222 /* No compiled RE interpolated, has runtime
2223 components ===> unsafe. */
2224 FAIL("Eval-group not allowed at runtime, use re 'eval'");
2225 if (PL_tainting && PL_tainted)
2226 FAIL("Eval-group in insecure regular expression");
2229 nextchar(pRExC_state);
2231 ret = reg_node(pRExC_state, LOGICAL);
2234 regtail(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
2235 /* deal with the length of this later - MJD */
2238 return reganode(pRExC_state, EVAL, n);
2240 case '(': /* (?(?{...})...) and (?(?=...)...) */
2242 if (RExC_parse[0] == '?') { /* (?(?...)) */
2243 if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
2244 || RExC_parse[1] == '<'
2245 || RExC_parse[1] == '{') { /* Lookahead or eval. */
2248 ret = reg_node(pRExC_state, LOGICAL);
2251 regtail(pRExC_state, ret, reg(pRExC_state, 1, &flag));
2255 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
2257 parno = atoi(RExC_parse++);
2259 while (isDIGIT(*RExC_parse))
2261 ret = reganode(pRExC_state, GROUPP, parno);
2263 if ((c = *nextchar(pRExC_state)) != ')')
2264 vFAIL("Switch condition not recognized");
2266 regtail(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
2267 br = regbranch(pRExC_state, &flags, 1);
2269 br = reganode(pRExC_state, LONGJMP, 0);
2271 regtail(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
2272 c = *nextchar(pRExC_state);
2276 lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
2277 regbranch(pRExC_state, &flags, 1);
2278 regtail(pRExC_state, ret, lastbr);
2281 c = *nextchar(pRExC_state);
2286 vFAIL("Switch (?(condition)... contains too many branches");
2287 ender = reg_node(pRExC_state, TAIL);
2288 regtail(pRExC_state, br, ender);
2290 regtail(pRExC_state, lastbr, ender);
2291 regtail(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
2294 regtail(pRExC_state, ret, ender);
2298 vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
2302 RExC_parse--; /* for vFAIL to print correctly */
2303 vFAIL("Sequence (? incomplete");
2307 parse_flags: /* (?i) */
2308 while (*RExC_parse && strchr("iogcmsx", *RExC_parse)) {
2309 /* (?g), (?gc) and (?o) are useless here
2310 and must be globally applied -- japhy */
2312 if (*RExC_parse == 'o' || *RExC_parse == 'g') {
2313 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
2314 I32 wflagbit = *RExC_parse == 'o' ? wasted_o : wasted_g;
2315 if (! (wastedflags & wflagbit) ) {
2316 wastedflags |= wflagbit;
2319 "Useless (%s%c) - %suse /%c modifier",
2320 flagsp == &negflags ? "?-" : "?",
2322 flagsp == &negflags ? "don't " : "",
2328 else if (*RExC_parse == 'c') {
2329 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
2330 if (! (wastedflags & wasted_c) ) {
2331 wastedflags |= wasted_gc;
2334 "Useless (%sc) - %suse /gc modifier",
2335 flagsp == &negflags ? "?-" : "?",
2336 flagsp == &negflags ? "don't " : ""
2341 else { pmflag(flagsp, *RExC_parse); }
2345 if (*RExC_parse == '-') {
2347 wastedflags = 0; /* reset so (?g-c) warns twice */
2351 RExC_flags16 |= posflags;
2352 RExC_flags16 &= ~negflags;
2353 if (*RExC_parse == ':') {
2359 if (*RExC_parse != ')') {
2361 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
2363 nextchar(pRExC_state);
2371 ret = reganode(pRExC_state, OPEN, parno);
2372 Set_Node_Length(ret, 1); /* MJD */
2373 Set_Node_Offset(ret, RExC_parse); /* MJD */
2380 /* Pick up the branches, linking them together. */
2381 parse_start = RExC_parse; /* MJD */
2382 br = regbranch(pRExC_state, &flags, 1);
2383 /* branch_len = (paren != 0); */
2387 if (*RExC_parse == '|') {
2388 if (!SIZE_ONLY && RExC_extralen) {
2389 reginsert(pRExC_state, BRANCHJ, br);
2392 reginsert(pRExC_state, BRANCH, br);
2393 Set_Node_Length(br, paren != 0);
2394 Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
2398 RExC_extralen += 1; /* For BRANCHJ-BRANCH. */
2400 else if (paren == ':') {
2401 *flagp |= flags&SIMPLE;
2403 if (open) { /* Starts with OPEN. */
2404 regtail(pRExC_state, ret, br); /* OPEN -> first. */
2406 else if (paren != '?') /* Not Conditional */
2408 *flagp |= flags & (SPSTART | HASWIDTH);
2410 while (*RExC_parse == '|') {
2411 if (!SIZE_ONLY && RExC_extralen) {
2412 ender = reganode(pRExC_state, LONGJMP,0);
2413 regtail(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
2416 RExC_extralen += 2; /* Account for LONGJMP. */
2417 nextchar(pRExC_state);
2418 br = regbranch(pRExC_state, &flags, 0);
2422 regtail(pRExC_state, lastbr, br); /* BRANCH -> BRANCH. */
2426 *flagp |= flags&SPSTART;
2429 if (have_branch || paren != ':') {
2430 /* Make a closing node, and hook it on the end. */
2433 ender = reg_node(pRExC_state, TAIL);
2436 ender = reganode(pRExC_state, CLOSE, parno);
2437 Set_Node_Offset(ender,RExC_parse+1); /* MJD */
2438 Set_Node_Length(ender,1); /* MJD */
2444 *flagp &= ~HASWIDTH;
2447 ender = reg_node(pRExC_state, SUCCEED);
2450 ender = reg_node(pRExC_state, END);
2453 regtail(pRExC_state, lastbr, ender);
2456 /* Hook the tails of the branches to the closing node. */
2457 for (br = ret; br != NULL; br = regnext(br)) {
2458 regoptail(pRExC_state, br, ender);
2465 static char parens[] = "=!<,>";
2467 if (paren && (p = strchr(parens, paren))) {
2468 int node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
2469 int flag = (p - parens) > 1;
2472 node = SUSPEND, flag = 0;
2473 reginsert(pRExC_state, node,ret);
2475 regtail(pRExC_state, ret, reg_node(pRExC_state, TAIL));
2479 /* Check for proper termination. */
2481 RExC_flags16 = oregflags;
2482 if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
2483 RExC_parse = oregcomp_parse;
2484 vFAIL("Unmatched (");
2487 else if (!paren && RExC_parse < RExC_end) {
2488 if (*RExC_parse == ')') {
2490 vFAIL("Unmatched )");
2493 FAIL("Junk on end of regexp"); /* "Can't happen". */
2501 - regbranch - one alternative of an | operator
2503 * Implements the concatenation operator.
2506 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first)
2508 register regnode *ret;
2509 register regnode *chain = NULL;
2510 register regnode *latest;
2511 I32 flags = 0, c = 0;
2516 if (!SIZE_ONLY && RExC_extralen)
2517 ret = reganode(pRExC_state, BRANCHJ,0);
2519 ret = reg_node(pRExC_state, BRANCH);
2520 Set_Node_Length(ret, 1);
2524 if (!first && SIZE_ONLY)
2525 RExC_extralen += 1; /* BRANCHJ */
2527 *flagp = WORST; /* Tentatively. */
2530 nextchar(pRExC_state);
2531 while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
2533 latest = regpiece(pRExC_state, &flags);
2534 if (latest == NULL) {
2535 if (flags & TRYAGAIN)
2539 else if (ret == NULL)
2541 *flagp |= flags&HASWIDTH;
2542 if (chain == NULL) /* First piece. */
2543 *flagp |= flags&SPSTART;
2546 regtail(pRExC_state, chain, latest);
2551 if (chain == NULL) { /* Loop ran zero times. */
2552 chain = reg_node(pRExC_state, NOTHING);
2557 *flagp |= flags&SIMPLE;
2564 - regpiece - something followed by possible [*+?]
2566 * Note that the branching code sequences used for ? and the general cases
2567 * of * and + are somewhat optimized: they use the same NOTHING node as
2568 * both the endmarker for their branch list and the body of the last branch.
2569 * It might seem that this node could be dispensed with entirely, but the
2570 * endmarker role is not redundant.
2573 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp)
2575 register regnode *ret;
2577 register char *next;
2579 char *origparse = RExC_parse;
2582 I32 max = REG_INFTY;
2585 ret = regatom(pRExC_state, &flags);
2587 if (flags & TRYAGAIN)
2594 if (op == '{' && regcurly(RExC_parse)) {
2595 parse_start = RExC_parse; /* MJD */
2596 next = RExC_parse + 1;
2598 while (isDIGIT(*next) || *next == ',') {
2607 if (*next == '}') { /* got one */
2611 min = atoi(RExC_parse);
2615 maxpos = RExC_parse;
2617 if (!max && *maxpos != '0')
2618 max = REG_INFTY; /* meaning "infinity" */
2619 else if (max >= REG_INFTY)
2620 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
2622 nextchar(pRExC_state);
2625 if ((flags&SIMPLE)) {
2626 RExC_naughty += 2 + RExC_naughty / 2;
2627 reginsert(pRExC_state, CURLY, ret);
2628 Set_Node_Offset(ret, parse_start+1); /* MJD */
2629 Set_Node_Cur_Length(ret);
2632 regnode *w = reg_node(pRExC_state, WHILEM);
2635 regtail(pRExC_state, ret, w);
2636 if (!SIZE_ONLY && RExC_extralen) {
2637 reginsert(pRExC_state, LONGJMP,ret);
2638 reginsert(pRExC_state, NOTHING,ret);
2639 NEXT_OFF(ret) = 3; /* Go over LONGJMP. */
2641 reginsert(pRExC_state, CURLYX,ret);
2643 Set_Node_Offset(ret, parse_start+1);
2644 Set_Node_Length(ret,
2645 op == '{' ? (RExC_parse - parse_start) : 1);
2647 if (!SIZE_ONLY && RExC_extralen)
2648 NEXT_OFF(ret) = 3; /* Go over NOTHING to LONGJMP. */
2649 regtail(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
2651 RExC_whilem_seen++, RExC_extralen += 3;
2652 RExC_naughty += 4 + RExC_naughty; /* compound interest */
2660 if (max && max < min)
2661 vFAIL("Can't do {n,m} with n > m");
2676 #if 0 /* Now runtime fix should be reliable. */
2678 /* if this is reinstated, don't forget to put this back into perldiag:
2680 =item Regexp *+ operand could be empty at {#} in regex m/%s/
2682 (F) The part of the regexp subject to either the * or + quantifier
2683 could match an empty string. The {#} shows in the regular
2684 expression about where the problem was discovered.
2688 if (!(flags&HASWIDTH) && op != '?')
2689 vFAIL("Regexp *+ operand could be empty");
2692 parse_start = RExC_parse;
2693 nextchar(pRExC_state);
2695 *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
2697 if (op == '*' && (flags&SIMPLE)) {
2698 reginsert(pRExC_state, STAR, ret);
2702 else if (op == '*') {
2706 else if (op == '+' && (flags&SIMPLE)) {
2707 reginsert(pRExC_state, PLUS, ret);
2711 else if (op == '+') {
2715 else if (op == '?') {
2720 if (ckWARN(WARN_REGEXP) && !SIZE_ONLY && !(flags&HASWIDTH) && max > REG_INFTY/3) {
2722 "%.*s matches null string many times",
2723 RExC_parse - origparse,
2727 if (*RExC_parse == '?') {
2728 nextchar(pRExC_state);
2729 reginsert(pRExC_state, MINMOD, ret);
2730 regtail(pRExC_state, ret, ret + NODE_STEP_REGNODE);
2732 if (ISMULT2(RExC_parse)) {
2734 vFAIL("Nested quantifiers");
2741 - regatom - the lowest level
2743 * Optimization: gobbles an entire sequence of ordinary characters so that
2744 * it can turn them into a single node, which is smaller to store and
2745 * faster to run. Backslashed characters are exceptions, each becoming a
2746 * separate node; the code is simpler that way and it's not worth fixing.
2748 * [Yes, it is worth fixing, some scripts can run twice the speed.] */
2750 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp)
2752 register regnode *ret = 0;
2754 char *parse_start = 0;
2756 *flagp = WORST; /* Tentatively. */
2759 switch (*RExC_parse) {
2761 RExC_seen_zerolen++;
2762 nextchar(pRExC_state);
2763 if (RExC_flags16 & PMf_MULTILINE)
2764 ret = reg_node(pRExC_state, MBOL);
2765 else if (RExC_flags16 & PMf_SINGLELINE)
2766 ret = reg_node(pRExC_state, SBOL);
2768 ret = reg_node(pRExC_state, BOL);
2769 Set_Node_Length(ret, 1); /* MJD */
2772 nextchar(pRExC_state);
2774 RExC_seen_zerolen++;
2775 if (RExC_flags16 & PMf_MULTILINE)
2776 ret = reg_node(pRExC_state, MEOL);
2777 else if (RExC_flags16 & PMf_SINGLELINE)
2778 ret = reg_node(pRExC_state, SEOL);
2780 ret = reg_node(pRExC_state, EOL);
2781 Set_Node_Length(ret, 1); /* MJD */
2784 nextchar(pRExC_state);
2785 if (RExC_flags16 & PMf_SINGLELINE)
2786 ret = reg_node(pRExC_state, SANY);
2788 ret = reg_node(pRExC_state, REG_ANY);
2789 *flagp |= HASWIDTH|SIMPLE;
2791 Set_Node_Length(ret, 1); /* MJD */
2795 char *oregcomp_parse = ++RExC_parse;
2796 ret = regclass(pRExC_state);
2797 if (*RExC_parse != ']') {
2798 RExC_parse = oregcomp_parse;
2799 vFAIL("Unmatched [");
2801 nextchar(pRExC_state);
2802 *flagp |= HASWIDTH|SIMPLE;
2803 Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
2807 nextchar(pRExC_state);
2808 ret = reg(pRExC_state, 1, &flags);
2810 if (flags & TRYAGAIN) {
2811 if (RExC_parse == RExC_end) {
2812 /* Make parent create an empty node if needed. */
2820 *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE);
2824 if (flags & TRYAGAIN) {
2828 vFAIL("Internal urp");
2829 /* Supposed to be caught earlier. */
2832 if (!regcurly(RExC_parse)) {
2841 vFAIL("Quantifier follows nothing");
2844 switch (*++RExC_parse) {
2846 RExC_seen_zerolen++;
2847 ret = reg_node(pRExC_state, SBOL);
2849 nextchar(pRExC_state);
2850 Set_Node_Length(ret, 2); /* MJD */
2853 ret = reg_node(pRExC_state, GPOS);
2854 RExC_seen |= REG_SEEN_GPOS;
2856 nextchar(pRExC_state);
2857 Set_Node_Length(ret, 2); /* MJD */
2860 ret = reg_node(pRExC_state, SEOL);
2862 RExC_seen_zerolen++; /* Do not optimize RE away */
2863 nextchar(pRExC_state);
2866 ret = reg_node(pRExC_state, EOS);
2868 RExC_seen_zerolen++; /* Do not optimize RE away */
2869 nextchar(pRExC_state);
2870 Set_Node_Length(ret, 2); /* MJD */
2873 ret = reg_node(pRExC_state, CANY);
2874 RExC_seen |= REG_SEEN_CANY;
2875 *flagp |= HASWIDTH|SIMPLE;
2876 nextchar(pRExC_state);
2877 Set_Node_Length(ret, 2); /* MJD */
2880 ret = reg_node(pRExC_state, CLUMP);
2882 nextchar(pRExC_state);
2883 Set_Node_Length(ret, 2); /* MJD */
2886 ret = reg_node(pRExC_state, LOC ? ALNUML : ALNUM);
2887 *flagp |= HASWIDTH|SIMPLE;
2888 nextchar(pRExC_state);
2889 Set_Node_Length(ret, 2); /* MJD */
2892 ret = reg_node(pRExC_state, LOC ? NALNUML : NALNUM);
2893 *flagp |= HASWIDTH|SIMPLE;
2894 nextchar(pRExC_state);
2895 Set_Node_Length(ret, 2); /* MJD */
2898 RExC_seen_zerolen++;
2899 RExC_seen |= REG_SEEN_LOOKBEHIND;
2900 ret = reg_node(pRExC_state, LOC ? BOUNDL : BOUND);
2902 nextchar(pRExC_state);
2903 Set_Node_Length(ret, 2); /* MJD */
2906 RExC_seen_zerolen++;
2907 RExC_seen |= REG_SEEN_LOOKBEHIND;
2908 ret = reg_node(pRExC_state, LOC ? NBOUNDL : NBOUND);
2910 nextchar(pRExC_state);
2911 Set_Node_Length(ret, 2); /* MJD */
2914 ret = reg_node(pRExC_state, LOC ? SPACEL : SPACE);
2915 *flagp |= HASWIDTH|SIMPLE;
2916 nextchar(pRExC_state);
2917 Set_Node_Length(ret, 2); /* MJD */
2920 ret = reg_node(pRExC_state, LOC ? NSPACEL : NSPACE);
2921 *flagp |= HASWIDTH|SIMPLE;
2922 nextchar(pRExC_state);
2923 Set_Node_Length(ret, 2); /* MJD */
2926 ret = reg_node(pRExC_state, DIGIT);
2927 *flagp |= HASWIDTH|SIMPLE;
2928 nextchar(pRExC_state);
2929 Set_Node_Length(ret, 2); /* MJD */
2932 ret = reg_node(pRExC_state, NDIGIT);
2933 *flagp |= HASWIDTH|SIMPLE;
2934 nextchar(pRExC_state);
2935 Set_Node_Length(ret, 2); /* MJD */
2940 char* oldregxend = RExC_end;
2941 char* parse_start = RExC_parse;
2943 if (RExC_parse[1] == '{') {
2944 /* a lovely hack--pretend we saw [\pX] instead */
2945 RExC_end = strchr(RExC_parse, '}');
2947 U8 c = (U8)*RExC_parse;
2949 RExC_end = oldregxend;
2950 vFAIL2("Missing right brace on \\%c{}", c);
2955 RExC_end = RExC_parse + 2;
2958 ret = regclass(pRExC_state);
2960 RExC_end = oldregxend;
2962 Set_Node_Cur_Length(ret); /* MJD */
2963 nextchar(pRExC_state);
2964 *flagp |= HASWIDTH|SIMPLE;
2977 case '1': case '2': case '3': case '4':
2978 case '5': case '6': case '7': case '8': case '9':
2980 I32 num = atoi(RExC_parse);
2982 if (num > 9 && num >= RExC_npar)
2985 char * parse_start = RExC_parse - 1; /* MJD */
2986 while (isDIGIT(*RExC_parse))
2989 if (!SIZE_ONLY && num > RExC_rx->nparens)
2990 vFAIL("Reference to nonexistent group");
2992 ret = reganode(pRExC_state, FOLD
2993 ? (LOC ? REFFL : REFF)
2997 /* override incorrect value set in reganode MJD */
2998 Set_Node_Offset(ret, parse_start+1);
2999 Set_Node_Cur_Length(ret); /* MJD */
3001 nextchar(pRExC_state);
3006 if (RExC_parse >= RExC_end)
3007 FAIL("Trailing \\");
3010 /* Do not generate `unrecognized' warnings here, we fall
3011 back into the quick-grab loop below */
3017 if (RExC_flags16 & PMf_EXTENDED) {
3018 while (RExC_parse < RExC_end && *RExC_parse != '\n') RExC_parse++;
3019 if (RExC_parse < RExC_end)
3025 register STRLEN len;
3031 U8 tmpbuf[UTF8_MAXLEN_FOLD+1], *foldbuf;
3033 parse_start = RExC_parse - 1;
3038 ret = reg_node(pRExC_state, FOLD
3039 ? (LOC ? EXACTFL : EXACTF)
3042 for (len = 0, p = RExC_parse - 1;
3043 len < 127 && p < RExC_end;
3048 if (RExC_flags16 & PMf_EXTENDED)
3049 p = regwhite(p, RExC_end);
3096 ender = ASCII_TO_NATIVE('\033');
3100 ender = ASCII_TO_NATIVE('\007');
3105 char* e = strchr(p, '}');
3109 vFAIL("Missing right brace on \\x{}");
3112 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3113 | PERL_SCAN_DISALLOW_PREFIX;
3115 ender = grok_hex(p + 1, &numlen, &flags, NULL);
3118 /* numlen is generous */
3119 if (numlen + len >= 127) {
3127 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
3129 ender = grok_hex(p, &numlen, &flags, NULL);
3135 ender = UCHARAT(p++);
3136 ender = toCTRL(ender);
3138 case '0': case '1': case '2': case '3':case '4':
3139 case '5': case '6': case '7': case '8':case '9':
3141 (isDIGIT(p[1]) && atoi(p) >= RExC_npar) ) {
3144 ender = grok_oct(p, &numlen, &flags, NULL);
3154 FAIL("Trailing \\");
3157 if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && isALPHA(*p))
3158 vWARN2(p + 1, "Unrecognized escape \\%c passed through", UCHARAT(p));
3159 goto normal_default;
3164 if (UTF8_IS_START(*p) && UTF) {
3165 ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
3173 if (RExC_flags16 & PMf_EXTENDED)
3174 p = regwhite(p, RExC_end);
3176 /* Prime the casefolded buffer. */
3177 ender = toFOLD_uni(ender, tmpbuf, &foldlen);
3179 if (ISMULT2(p)) { /* Back off on ?+*. */
3184 /* Emit all the Unicode characters. */
3185 for (foldbuf = tmpbuf;
3187 foldlen -= numlen) {
3188 ender = utf8_to_uvchr(foldbuf, &numlen);
3189 reguni(pRExC_state, ender, s, &numlen);
3196 reguni(pRExC_state, ender, s, &numlen);
3209 /* Emit all the Unicode characters. */
3210 for (foldbuf = tmpbuf;
3212 foldlen -= numlen) {
3213 ender = utf8_to_uvchr(foldbuf, &numlen);
3214 reguni(pRExC_state, ender, s, &numlen);
3221 reguni(pRExC_state, ender, s, &numlen);
3232 Set_Node_Cur_Length(ret); /* MJD */
3233 nextchar(pRExC_state);
3235 /* len is STRLEN which is unsigned, need to copy to signed */
3238 vFAIL("Internal disaster");
3247 RExC_size += STR_SZ(len);
3249 RExC_emit += STR_SZ(len);
3254 /* If the encoding pragma is in effect recode the text of
3255 * any EXACT-kind nodes. */
3256 if (PL_encoding && PL_regkind[(U8)OP(ret)] == EXACT) {
3257 STRLEN oldlen = STR_LEN(ret);
3258 SV *sv = sv_2mortal(newSVpvn(STRING(ret), oldlen));
3262 if (sv_utf8_downgrade(sv, TRUE)) {
3263 char *s = Perl_sv_recode_to_utf8(aTHX_ sv, PL_encoding);
3264 STRLEN newlen = SvCUR(sv);
3267 DEBUG_r(PerlIO_printf(Perl_debug_log, "recode %*s to %*s\n",
3268 (int)oldlen, STRING(ret),
3270 Copy(s, STRING(ret), newlen, char);
3271 STR_LEN(ret) += newlen - oldlen;
3272 RExC_emit += STR_SZ(newlen) - STR_SZ(oldlen);
3274 RExC_size += STR_SZ(newlen) - STR_SZ(oldlen);
3282 S_regwhite(pTHX_ char *p, char *e)
3287 else if (*p == '#') {
3290 } while (p < e && *p != '\n');
3298 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
3299 Character classes ([:foo:]) can also be negated ([:^foo:]).
3300 Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
3301 Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
3302 but trigger failures because they are currently unimplemented. */
3304 #define POSIXCC_DONE(c) ((c) == ':')
3305 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
3306 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
3309 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
3312 I32 namedclass = OOB_NAMEDCLASS;
3314 if (value == '[' && RExC_parse + 1 < RExC_end &&
3315 /* I smell either [: or [= or [. -- POSIX has been here, right? */
3316 POSIXCC(UCHARAT(RExC_parse))) {
3317 char c = UCHARAT(RExC_parse);
3318 char* s = RExC_parse++;
3320 while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
3322 if (RExC_parse == RExC_end)
3323 /* Grandfather lone [:, [=, [. */
3326 char* t = RExC_parse++; /* skip over the c */
3328 if (UCHARAT(RExC_parse) == ']') {
3329 RExC_parse++; /* skip over the ending ] */
3332 I32 complement = *posixcc == '^' ? *posixcc++ : 0;
3333 I32 skip = 5; /* the most common skip */
3337 if (strnEQ(posixcc, "alnum", 5))
3339 complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
3340 else if (strnEQ(posixcc, "alpha", 5))
3342 complement ? ANYOF_NALPHA : ANYOF_ALPHA;
3343 else if (strnEQ(posixcc, "ascii", 5))
3345 complement ? ANYOF_NASCII : ANYOF_ASCII;
3348 if (strnEQ(posixcc, "blank", 5))
3350 complement ? ANYOF_NBLANK : ANYOF_BLANK;
3353 if (strnEQ(posixcc, "cntrl", 5))
3355 complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
3358 if (strnEQ(posixcc, "digit", 5))
3360 complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
3363 if (strnEQ(posixcc, "graph", 5))
3365 complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
3368 if (strnEQ(posixcc, "lower", 5))
3370 complement ? ANYOF_NLOWER : ANYOF_LOWER;
3373 if (strnEQ(posixcc, "print", 5))
3375 complement ? ANYOF_NPRINT : ANYOF_PRINT;
3376 else if (strnEQ(posixcc, "punct", 5))
3378 complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
3381 if (strnEQ(posixcc, "space", 5))
3383 complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
3386 if (strnEQ(posixcc, "upper", 5))
3388 complement ? ANYOF_NUPPER : ANYOF_UPPER;
3390 case 'w': /* this is not POSIX, this is the Perl \w */
3391 if (strnEQ(posixcc, "word", 4)) {
3393 complement ? ANYOF_NALNUM : ANYOF_ALNUM;
3398 if (strnEQ(posixcc, "xdigit", 6)) {
3400 complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
3405 if (namedclass == OOB_NAMEDCLASS ||
3406 posixcc[skip] != ':' ||
3407 posixcc[skip+1] != ']')
3409 Simple_vFAIL3("POSIX class [:%.*s:] unknown",
3412 } else if (!SIZE_ONLY) {
3413 /* [[=foo=]] and [[.foo.]] are still future. */
3415 /* adjust RExC_parse so the warning shows after
3417 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
3419 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
3422 /* Maternal grandfather:
3423 * "[:" ending in ":" but not in ":]" */
3433 S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
3435 if (!SIZE_ONLY && ckWARN(WARN_REGEXP) &&
3436 POSIXCC(UCHARAT(RExC_parse))) {
3437 char *s = RExC_parse;
3440 while(*s && isALNUM(*s))
3442 if (*s && c == *s && s[1] == ']') {
3443 vWARN3(s+2, "POSIX syntax [%c %c] belongs inside character classes", c, c);
3445 /* [[=foo=]] and [[.foo.]] are still future. */
3446 if (POSIXCC_NOTYET(c)) {
3447 /* adjust RExC_parse so the error shows after
3449 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
3451 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
3458 S_regclass(pTHX_ RExC_state_t *pRExC_state)
3461 register UV nextvalue;
3462 register IV prevvalue = OOB_UNICODE;
3463 register IV range = 0;
3464 register regnode *ret;
3467 char *rangebegin = 0;
3468 bool need_class = 0;
3469 SV *listsv = Nullsv;
3472 bool optimize_invert = TRUE;
3473 AV* unicode_alternate = 0;
3475 ret = reganode(pRExC_state, ANYOF, 0);
3478 ANYOF_FLAGS(ret) = 0;
3480 if (UCHARAT(RExC_parse) == '^') { /* Complement of range. */
3484 ANYOF_FLAGS(ret) |= ANYOF_INVERT;
3488 RExC_size += ANYOF_SKIP;
3490 RExC_emit += ANYOF_SKIP;
3492 ANYOF_FLAGS(ret) |= ANYOF_FOLD;
3494 ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
3495 ANYOF_BITMAP_ZERO(ret);
3496 listsv = newSVpvn("# comment\n", 10);
3499 nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
3501 if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && POSIXCC(nextvalue))
3502 checkposixcc(pRExC_state);
3504 /* allow 1st char to be ] (allowing it to be - is dealt with later) */
3505 if (UCHARAT(RExC_parse) == ']')
3508 while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
3512 namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
3515 rangebegin = RExC_parse;
3517 value = utf8n_to_uvchr((U8*)RExC_parse,
3518 RExC_end - RExC_parse,
3520 RExC_parse += numlen;
3523 value = UCHARAT(RExC_parse++);
3524 nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
3525 if (value == '[' && POSIXCC(nextvalue))
3526 namedclass = regpposixcc(pRExC_state, value);
3527 else if (value == '\\') {
3529 value = utf8n_to_uvchr((U8*)RExC_parse,
3530 RExC_end - RExC_parse,
3532 RExC_parse += numlen;
3535 value = UCHARAT(RExC_parse++);
3536 /* Some compilers cannot handle switching on 64-bit integer
3537 * values, therefore value cannot be an UV. Yes, this will
3538 * be a problem later if we want switch on Unicode.
3539 * A similar issue a little bit later when switching on
3540 * namedclass. --jhi */
3541 switch ((I32)value) {
3542 case 'w': namedclass = ANYOF_ALNUM; break;
3543 case 'W': namedclass = ANYOF_NALNUM; break;
3544 case 's': namedclass = ANYOF_SPACE; break;
3545 case 'S': namedclass = ANYOF_NSPACE; break;
3546 case 'd': namedclass = ANYOF_DIGIT; break;
3547 case 'D': namedclass = ANYOF_NDIGIT; break;
3550 if (*RExC_parse == '{') {
3552 e = strchr(RExC_parse++, '}');
3554 vFAIL2("Missing right brace on \\%c{}", c);
3555 while (isSPACE(UCHARAT(RExC_parse)))
3557 if (e == RExC_parse)
3558 vFAIL2("Empty \\%c{}", c);
3560 while (isSPACE(UCHARAT(RExC_parse + n - 1)))
3568 if (UCHARAT(RExC_parse) == '^') {
3571 value = value == 'p' ? 'P' : 'p'; /* toggle */
3572 while (isSPACE(UCHARAT(RExC_parse))) {
3578 Perl_sv_catpvf(aTHX_ listsv,
3579 "+utf8::%.*s\n", (int)n, RExC_parse);
3581 Perl_sv_catpvf(aTHX_ listsv,
3582 "!utf8::%.*s\n", (int)n, RExC_parse);
3585 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
3587 case 'n': value = '\n'; break;
3588 case 'r': value = '\r'; break;
3589 case 't': value = '\t'; break;
3590 case 'f': value = '\f'; break;
3591 case 'b': value = '\b'; break;
3592 case 'e': value = ASCII_TO_NATIVE('\033');break;
3593 case 'a': value = ASCII_TO_NATIVE('\007');break;
3595 if (*RExC_parse == '{') {
3596 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
3597 | PERL_SCAN_DISALLOW_PREFIX;
3598 e = strchr(RExC_parse++, '}');
3600 vFAIL("Missing right brace on \\x{}");
3602 numlen = e - RExC_parse;
3603 value = grok_hex(RExC_parse, &numlen, &flags, NULL);
3607 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
3609 value = grok_hex(RExC_parse, &numlen, &flags, NULL);
3610 RExC_parse += numlen;
3614 value = UCHARAT(RExC_parse++);
3615 value = toCTRL(value);
3617 case '0': case '1': case '2': case '3': case '4':
3618 case '5': case '6': case '7': case '8': case '9':
3622 value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
3623 RExC_parse += numlen;
3627 if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && isALPHA(value))
3629 "Unrecognized escape \\%c in character class passed through",
3633 } /* end of \blah */
3635 if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
3637 if (!SIZE_ONLY && !need_class)
3638 ANYOF_CLASS_ZERO(ret);
3642 /* a bad range like a-\d, a-[:digit:] ? */
3645 if (ckWARN(WARN_REGEXP))
3647 "False [] range \"%*.*s\"",
3648 RExC_parse - rangebegin,
3649 RExC_parse - rangebegin,
3651 if (prevvalue < 256) {
3652 ANYOF_BITMAP_SET(ret, prevvalue);
3653 ANYOF_BITMAP_SET(ret, '-');
3656 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
3657 Perl_sv_catpvf(aTHX_ listsv,
3658 "%04"UVxf"\n%04"UVxf"\n", (UV)prevvalue, (UV) '-');
3662 range = 0; /* this was not a true range */
3666 if (namedclass > OOB_NAMEDCLASS)
3667 optimize_invert = FALSE;
3668 /* Possible truncation here but in some 64-bit environments
3669 * the compiler gets heartburn about switch on 64-bit values.
3670 * A similar issue a little earlier when switching on value.
3672 switch ((I32)namedclass) {
3675 ANYOF_CLASS_SET(ret, ANYOF_ALNUM);
3677 for (value = 0; value < 256; value++)
3679 ANYOF_BITMAP_SET(ret, value);
3681 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsWord\n");
3685 ANYOF_CLASS_SET(ret, ANYOF_NALNUM);
3687 for (value = 0; value < 256; value++)
3688 if (!isALNUM(value))
3689 ANYOF_BITMAP_SET(ret, value);
3691 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsWord\n");
3695 ANYOF_CLASS_SET(ret, ANYOF_ALNUMC);
3697 for (value = 0; value < 256; value++)
3698 if (isALNUMC(value))
3699 ANYOF_BITMAP_SET(ret, value);
3701 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsAlnum\n");
3705 ANYOF_CLASS_SET(ret, ANYOF_NALNUMC);
3707 for (value = 0; value < 256; value++)
3708 if (!isALNUMC(value))
3709 ANYOF_BITMAP_SET(ret, value);
3711 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsAlnum\n");
3715 ANYOF_CLASS_SET(ret, ANYOF_ALPHA);
3717 for (value = 0; value < 256; value++)
3719 ANYOF_BITMAP_SET(ret, value);
3721 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsAlpha\n");
3725 ANYOF_CLASS_SET(ret, ANYOF_NALPHA);
3727 for (value = 0; value < 256; value++)
3728 if (!isALPHA(value))
3729 ANYOF_BITMAP_SET(ret, value);
3731 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsAlpha\n");
3735 ANYOF_CLASS_SET(ret, ANYOF_ASCII);
3738 for (value = 0; value < 128; value++)
3739 ANYOF_BITMAP_SET(ret, value);
3741 for (value = 0; value < 256; value++) {
3743 ANYOF_BITMAP_SET(ret, value);
3747 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsASCII\n");
3751 ANYOF_CLASS_SET(ret, ANYOF_NASCII);
3754 for (value = 128; value < 256; value++)
3755 ANYOF_BITMAP_SET(ret, value);
3757 for (value = 0; value < 256; value++) {
3758 if (!isASCII(value))
3759 ANYOF_BITMAP_SET(ret, value);
3763 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsASCII\n");
3767 ANYOF_CLASS_SET(ret, ANYOF_BLANK);
3769 for (value = 0; value < 256; value++)
3771 ANYOF_BITMAP_SET(ret, value);
3773 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsBlank\n");
3777 ANYOF_CLASS_SET(ret, ANYOF_NBLANK);
3779 for (value = 0; value < 256; value++)
3780 if (!isBLANK(value))
3781 ANYOF_BITMAP_SET(ret, value);
3783 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsBlank\n");
3787 ANYOF_CLASS_SET(ret, ANYOF_CNTRL);
3789 for (value = 0; value < 256; value++)
3791 ANYOF_BITMAP_SET(ret, value);
3793 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsCntrl\n");
3797 ANYOF_CLASS_SET(ret, ANYOF_NCNTRL);
3799 for (value = 0; value < 256; value++)
3800 if (!isCNTRL(value))
3801 ANYOF_BITMAP_SET(ret, value);
3803 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsCntrl\n");
3807 ANYOF_CLASS_SET(ret, ANYOF_DIGIT);
3809 /* consecutive digits assumed */
3810 for (value = '0'; value <= '9'; value++)
3811 ANYOF_BITMAP_SET(ret, value);
3813 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsDigit\n");
3817 ANYOF_CLASS_SET(ret, ANYOF_NDIGIT);
3819 /* consecutive digits assumed */
3820 for (value = 0; value < '0'; value++)
3821 ANYOF_BITMAP_SET(ret, value);
3822 for (value = '9' + 1; value < 256; value++)
3823 ANYOF_BITMAP_SET(ret, value);
3825 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsDigit\n");
3829 ANYOF_CLASS_SET(ret, ANYOF_GRAPH);
3831 for (value = 0; value < 256; value++)
3833 ANYOF_BITMAP_SET(ret, value);
3835 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsGraph\n");
3839 ANYOF_CLASS_SET(ret, ANYOF_NGRAPH);
3841 for (value = 0; value < 256; value++)
3842 if (!isGRAPH(value))
3843 ANYOF_BITMAP_SET(ret, value);
3845 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsGraph\n");
3849 ANYOF_CLASS_SET(ret, ANYOF_LOWER);
3851 for (value = 0; value < 256; value++)
3853 ANYOF_BITMAP_SET(ret, value);
3855 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsLower\n");
3859 ANYOF_CLASS_SET(ret, ANYOF_NLOWER);
3861 for (value = 0; value < 256; value++)
3862 if (!isLOWER(value))
3863 ANYOF_BITMAP_SET(ret, value);
3865 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsLower\n");
3869 ANYOF_CLASS_SET(ret, ANYOF_PRINT);
3871 for (value = 0; value < 256; value++)
3873 ANYOF_BITMAP_SET(ret, value);
3875 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsPrint\n");
3879 ANYOF_CLASS_SET(ret, ANYOF_NPRINT);
3881 for (value = 0; value < 256; value++)
3882 if (!isPRINT(value))
3883 ANYOF_BITMAP_SET(ret, value);
3885 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsPrint\n");
3889 ANYOF_CLASS_SET(ret, ANYOF_PSXSPC);
3891 for (value = 0; value < 256; value++)
3892 if (isPSXSPC(value))
3893 ANYOF_BITMAP_SET(ret, value);
3895 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsSpace\n");
3899 ANYOF_CLASS_SET(ret, ANYOF_NPSXSPC);
3901 for (value = 0; value < 256; value++)
3902 if (!isPSXSPC(value))
3903 ANYOF_BITMAP_SET(ret, value);
3905 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsSpace\n");
3909 ANYOF_CLASS_SET(ret, ANYOF_PUNCT);
3911 for (value = 0; value < 256; value++)
3913 ANYOF_BITMAP_SET(ret, value);
3915 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsPunct\n");
3919 ANYOF_CLASS_SET(ret, ANYOF_NPUNCT);
3921 for (value = 0; value < 256; value++)
3922 if (!isPUNCT(value))
3923 ANYOF_BITMAP_SET(ret, value);
3925 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsPunct\n");
3929 ANYOF_CLASS_SET(ret, ANYOF_SPACE);
3931 for (value = 0; value < 256; value++)
3933 ANYOF_BITMAP_SET(ret, value);
3935 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsSpacePerl\n");
3939 ANYOF_CLASS_SET(ret, ANYOF_NSPACE);
3941 for (value = 0; value < 256; value++)
3942 if (!isSPACE(value))
3943 ANYOF_BITMAP_SET(ret, value);
3945 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsSpacePerl\n");
3949 ANYOF_CLASS_SET(ret, ANYOF_UPPER);
3951 for (value = 0; value < 256; value++)
3953 ANYOF_BITMAP_SET(ret, value);
3955 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsUpper\n");
3959 ANYOF_CLASS_SET(ret, ANYOF_NUPPER);
3961 for (value = 0; value < 256; value++)
3962 if (!isUPPER(value))
3963 ANYOF_BITMAP_SET(ret, value);
3965 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsUpper\n");
3969 ANYOF_CLASS_SET(ret, ANYOF_XDIGIT);
3971 for (value = 0; value < 256; value++)
3972 if (isXDIGIT(value))
3973 ANYOF_BITMAP_SET(ret, value);
3975 Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsXDigit\n");
3979 ANYOF_CLASS_SET(ret, ANYOF_NXDIGIT);
3981 for (value = 0; value < 256; value++)
3982 if (!isXDIGIT(value))
3983 ANYOF_BITMAP_SET(ret, value);
3985 Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsXDigit\n");
3988 vFAIL("Invalid [::] class");
3992 ANYOF_FLAGS(ret) |= ANYOF_CLASS;
3995 } /* end of namedclass \blah */
3998 if (prevvalue > value) /* b-a */ {
3999 Simple_vFAIL4("Invalid [] range \"%*.*s\"",
4000 RExC_parse - rangebegin,
4001 RExC_parse - rangebegin,
4003 range = 0; /* not a valid range */
4007 prevvalue = value; /* save the beginning of the range */
4008 if (*RExC_parse == '-' && RExC_parse+1 < RExC_end &&
4009 RExC_parse[1] != ']') {
4012 /* a bad range like \w-, [:word:]- ? */
4013 if (namedclass > OOB_NAMEDCLASS) {
4014 if (ckWARN(WARN_REGEXP))
4016 "False [] range \"%*.*s\"",
4017 RExC_parse - rangebegin,
4018 RExC_parse - rangebegin,
4021 ANYOF_BITMAP_SET(ret, '-');
4023 range = 1; /* yeah, it's a range! */
4024 continue; /* but do it the next time */
4028 /* now is the next time */
4032 if (prevvalue < 256) {
4033 IV ceilvalue = value < 256 ? value : 255;
4036 if ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
4037 (isUPPER(prevvalue) && isUPPER(ceilvalue)))
4039 if (isLOWER(prevvalue)) {
4040 for (i = prevvalue; i <= ceilvalue; i++)
4042 ANYOF_BITMAP_SET(ret, i);
4044 for (i = prevvalue; i <= ceilvalue; i++)
4046 ANYOF_BITMAP_SET(ret, i);
4051 for (i = prevvalue; i <= ceilvalue; i++)
4052 ANYOF_BITMAP_SET(ret, i);
4054 if (value > 255 || UTF) {
4055 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
4056 if (prevvalue < value)
4057 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
4058 (UV)prevvalue, (UV)value);
4059 else if (prevvalue == value) {
4060 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
4063 U8 tmpbuf [UTF8_MAXLEN+1];
4064 U8 foldbuf[UTF8_MAXLEN_FOLD+1];
4068 uvchr_to_utf8(tmpbuf, value);
4069 to_utf8_fold(tmpbuf, foldbuf, &foldlen);
4070 f = utf8_to_uvchr(foldbuf, 0);
4072 /* If folding and foldable and a single
4073 * character, insert also the folded version
4074 * to the charclass. */
4076 if (foldlen == UNISKIP(f))
4077 Perl_sv_catpvf(aTHX_ listsv,
4080 /* Any multicharacter foldings
4081 * require the following transform:
4082 * [ABCDEF] -> (?:[ABCabcDEFd]|pq|rst)
4083 * where E folds into "pq" and F folds
4084 * into "rst", all other characters
4085 * fold to single characters. We save
4086 * away these multicharacter foldings,
4087 * to be later saved as part of the
4088 * additional "s" data. */
4091 if (!unicode_alternate)
4092 unicode_alternate = newAV();
4093 sv = newSVpvn((char*)foldbuf, foldlen);
4095 av_push(unicode_alternate, sv);
4099 /* If folding and the value is one of the Greek
4100 * sigmas insert a few more sigmas to make the
4101 * folding rules of the sigmas to work right.
4102 * Note that not all the possible combinations
4103 * are handled here: some of them are handled
4104 * by the standard folding rules, and some of
4105 * them (literal or EXACTF cases) are handled
4106 * during runtime in regexec.c:S_find_byclass(). */
4107 if (value == UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA) {
4108 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
4109 (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA);
4110 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
4111 (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
4113 else if (value == UNICODE_GREEK_CAPITAL_LETTER_SIGMA)
4114 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
4115 (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
4121 range = 0; /* this range (if it was one) is done now */
4125 ANYOF_FLAGS(ret) |= ANYOF_LARGE;
4127 RExC_size += ANYOF_CLASS_ADD_SKIP;
4129 RExC_emit += ANYOF_CLASS_ADD_SKIP;
4132 /* optimize case-insensitive simple patterns (e.g. /[a-z]/i) */
4134 /* If the only flag is folding (plus possibly inversion). */
4135 ((ANYOF_FLAGS(ret) & (ANYOF_FLAGS_ALL ^ ANYOF_INVERT)) == ANYOF_FOLD)
4137 for (value = 0; value < 256; ++value) {
4138 if (ANYOF_BITMAP_TEST(ret, value)) {
4139 IV fold = PL_fold[value];
4142 ANYOF_BITMAP_SET(ret, fold);
4145 ANYOF_FLAGS(ret) &= ~ANYOF_FOLD;
4148 /* optimize inverted simple patterns (e.g. [^a-z]) */
4149 if (!SIZE_ONLY && optimize_invert &&
4150 /* If the only flag is inversion. */
4151 (ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT) {
4152 for (value = 0; value < ANYOF_BITMAP_SIZE; ++value)
4153 ANYOF_BITMAP(ret)[value] ^= ANYOF_FLAGS_ALL;
4154 ANYOF_FLAGS(ret) = ANYOF_UNICODE_ALL;
4161 /* The 0th element stores the character class description
4162 * in its textual form: used later (regexec.c:Perl_regclass_swatch())
4163 * to initialize the appropriate swash (which gets stored in
4164 * the 1st element), and also useful for dumping the regnode.
4165 * The 2nd element stores the multicharacter foldings,
4166 * used later (regexec.c:s_reginclasslen()). */
4167 av_store(av, 0, listsv);
4168 av_store(av, 1, NULL);
4169 av_store(av, 2, (SV*)unicode_alternate);
4170 rv = newRV_noinc((SV*)av);
4171 n = add_data(pRExC_state, 1, "s");
4172 RExC_rx->data->data[n] = (void*)rv;
4180 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
4182 char* retval = RExC_parse++;
4185 if (*RExC_parse == '(' && RExC_parse[1] == '?' &&
4186 RExC_parse[2] == '#') {
4187 while (*RExC_parse && *RExC_parse != ')')
4192 if (RExC_flags16 & PMf_EXTENDED) {
4193 if (isSPACE(*RExC_parse)) {
4197 else if (*RExC_parse == '#') {
4198 while (*RExC_parse && *RExC_parse != '\n')
4209 - reg_node - emit a node
4211 STATIC regnode * /* Location. */
4212 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
4214 register regnode *ret;
4215 register regnode *ptr;
4219 SIZE_ALIGN(RExC_size);
4224 NODE_ALIGN_FILL(ret);
4226 FILL_ADVANCE_NODE(ptr, op);
4227 if (RExC_offsets) { /* MJD */
4228 MJD_OFFSET_DEBUG((stderr, "%s:%u: (op %s) %s %u <- %u (len %u) (max %u).\n",
4229 "reg_node", __LINE__,
4231 RExC_emit - RExC_emit_start > RExC_offsets[0]
4232 ? "Overwriting end of array!\n" : "OK",
4233 RExC_emit - RExC_emit_start,
4234 RExC_parse - RExC_start,
4236 Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
4245 - reganode - emit a node with an argument
4247 STATIC regnode * /* Location. */
4248 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
4250 register regnode *ret;
4251 register regnode *ptr;
4255 SIZE_ALIGN(RExC_size);
4260 NODE_ALIGN_FILL(ret);
4262 FILL_ADVANCE_NODE_ARG(ptr, op, arg);
4263 if (RExC_offsets) { /* MJD */
4264 MJD_OFFSET_DEBUG((stderr, "%s: %s %u <- %u (max %u).\n",
4266 RExC_emit - RExC_emit_start > RExC_offsets[0] ?
4267 "Overwriting end of array!\n" : "OK",
4268 RExC_emit - RExC_emit_start,
4269 RExC_parse - RExC_start,
4271 Set_Cur_Node_Offset;
4280 - reguni - emit (if appropriate) a Unicode character
4283 S_reguni(pTHX_ RExC_state_t *pRExC_state, UV uv, char* s, STRLEN* lenp)
4285 *lenp = SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
4289 - reginsert - insert an operator in front of already-emitted operand
4291 * Means relocating the operand.
4294 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd)
4296 register regnode *src;
4297 register regnode *dst;
4298 register regnode *place;
4299 register int offset = regarglen[(U8)op];
4301 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
4304 RExC_size += NODE_STEP_REGNODE + offset;
4309 RExC_emit += NODE_STEP_REGNODE + offset;
4311 while (src > opnd) {
4312 StructCopy(--src, --dst, regnode);
4313 if (RExC_offsets) { /* MJD 20010112 */
4314 MJD_OFFSET_DEBUG((stderr, "%s: %s copy %u -> %u (max %u).\n",
4316 dst - RExC_emit_start > RExC_offsets[0]
4317 ? "Overwriting end of array!\n" : "OK",
4318 src - RExC_emit_start,
4319 dst - RExC_emit_start,
4321 Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
4322 Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
4327 place = opnd; /* Op node, where operand used to be. */
4328 if (RExC_offsets) { /* MJD */
4329 MJD_OFFSET_DEBUG((stderr, "%s: %s %u <- %u (max %u).\n",
4331 place - RExC_emit_start > RExC_offsets[0]
4332 ? "Overwriting end of array!\n" : "OK",
4333 place - RExC_emit_start,
4334 RExC_parse - RExC_start,
4336 Set_Node_Offset(place, RExC_parse);
4338 src = NEXTOPER(place);
4339 FILL_ADVANCE_NODE(place, op);
4340 Zero(src, offset, regnode);
4344 - regtail - set the next-pointer at the end of a node chain of p to val.
4347 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, regnode *val)
4349 register regnode *scan;
4350 register regnode *temp;
4355 /* Find last node. */
4358 temp = regnext(scan);
4364 if (reg_off_by_arg[OP(scan)]) {
4365 ARG_SET(scan, val - scan);
4368 NEXT_OFF(scan) = val - scan;
4373 - regoptail - regtail on operand of first argument; nop if operandless
4376 S_regoptail(pTHX_ RExC_state_t *pRExC_state, regnode *p, regnode *val)
4378 /* "Operandless" and "op != BRANCH" are synonymous in practice. */
4379 if (p == NULL || SIZE_ONLY)
4381 if (PL_regkind[(U8)OP(p)] == BRANCH) {
4382 regtail(pRExC_state, NEXTOPER(p), val);
4384 else if ( PL_regkind[(U8)OP(p)] == BRANCHJ) {
4385 regtail(pRExC_state, NEXTOPER(NEXTOPER(p)), val);
4392 - regcurly - a little FSA that accepts {\d+,?\d*}
4395 S_regcurly(pTHX_ register char *s)
4416 S_dumpuntil(pTHX_ regnode *start, regnode *node, regnode *last, SV* sv, I32 l)
4418 register U8 op = EXACT; /* Arbitrary non-END op. */
4419 register regnode *next;
4421 while (op != END && (!last || node < last)) {
4422 /* While that wasn't END last time... */
4428 next = regnext(node);
4430 if (OP(node) == OPTIMIZED)
4433 PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
4434 (int)(2*l + 1), "", SvPVX(sv));
4435 if (next == NULL) /* Next ptr. */
4436 PerlIO_printf(Perl_debug_log, "(0)");
4438 PerlIO_printf(Perl_debug_log, "(%"IVdf")", (IV)(next - start));
4439 (void)PerlIO_putc(Perl_debug_log, '\n');
4441 if (PL_regkind[(U8)op] == BRANCHJ) {
4442 register regnode *nnode = (OP(next) == LONGJMP
4445 if (last && nnode > last)
4447 node = dumpuntil(start, NEXTOPER(NEXTOPER(node)), nnode, sv, l + 1);
4449 else if (PL_regkind[(U8)op] == BRANCH) {
4450 node = dumpuntil(start, NEXTOPER(node), next, sv, l + 1);
4452 else if ( op == CURLY) { /* `next' might be very big: optimizer */
4453 node = dumpuntil(start, NEXTOPER(node) + EXTRA_STEP_2ARGS,
4454 NEXTOPER(node) + EXTRA_STEP_2ARGS + 1, sv, l + 1);
4456 else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
4457 node = dumpuntil(start, NEXTOPER(node) + EXTRA_STEP_2ARGS,
4460 else if ( op == PLUS || op == STAR) {
4461 node = dumpuntil(start, NEXTOPER(node), NEXTOPER(node) + 1, sv, l + 1);
4463 else if (op == ANYOF) {
4464 /* arglen 1 + class block */
4465 node += 1 + ((ANYOF_FLAGS(node) & ANYOF_LARGE)
4466 ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
4467 node = NEXTOPER(node);
4469 else if (PL_regkind[(U8)op] == EXACT) {
4470 /* Literal string, where present. */
4471 node += NODE_SZ_STR(node) - 1;
4472 node = NEXTOPER(node);
4475 node = NEXTOPER(node);
4476 node += regarglen[(U8)op];
4478 if (op == CURLYX || op == OPEN)
4480 else if (op == WHILEM)
4486 #endif /* DEBUGGING */
4489 - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
4492 Perl_regdump(pTHX_ regexp *r)
4495 SV *sv = sv_newmortal();
4497 (void)dumpuntil(r->program, r->program + 1, NULL, sv, 0);
4499 /* Header fields of interest. */
4500 if (r->anchored_substr)
4501 PerlIO_printf(Perl_debug_log,
4502 "anchored `%s%.*s%s'%s at %"IVdf" ",
4504 (int)(SvCUR(r->anchored_substr) - (SvTAIL(r->anchored_substr)!=0)),
4505 SvPVX(r->anchored_substr),
4507 SvTAIL(r->anchored_substr) ? "$" : "",
4508 (IV)r->anchored_offset);
4509 if (r->float_substr)
4510 PerlIO_printf(Perl_debug_log,
4511 "floating `%s%.*s%s'%s at %"IVdf"..%"UVuf" ",
4513 (int)(SvCUR(r->float_substr) - (SvTAIL(r->float_substr)!=0)),
4514 SvPVX(r->float_substr),
4516 SvTAIL(r->float_substr) ? "$" : "",
4517 (IV)r->float_min_offset, (UV)r->float_max_offset);
4518 if (r->check_substr)
4519 PerlIO_printf(Perl_debug_log,
4520 r->check_substr == r->float_substr
4521 ? "(checking floating" : "(checking anchored");
4522 if (r->reganch & ROPT_NOSCAN)
4523 PerlIO_printf(Perl_debug_log, " noscan");
4524 if (r->reganch & ROPT_CHECK_ALL)
4525 PerlIO_printf(Perl_debug_log, " isall");
4526 if (r->check_substr)
4527 PerlIO_printf(Perl_debug_log, ") ");
4529 if (r->regstclass) {
4530 regprop(sv, r->regstclass);
4531 PerlIO_printf(Perl_debug_log, "stclass `%s' ", SvPVX(sv));
4533 if (r->reganch & ROPT_ANCH) {
4534 PerlIO_printf(Perl_debug_log, "anchored");
4535 if (r->reganch & ROPT_ANCH_BOL)
4536 PerlIO_printf(Perl_debug_log, "(BOL)");
4537 if (r->reganch & ROPT_ANCH_MBOL)
4538 PerlIO_printf(Perl_debug_log, "(MBOL)");
4539 if (r->reganch & ROPT_ANCH_SBOL)
4540 PerlIO_printf(Perl_debug_log, "(SBOL)");
4541 if (r->reganch & ROPT_ANCH_GPOS)
4542 PerlIO_printf(Perl_debug_log, "(GPOS)");
4543 PerlIO_putc(Perl_debug_log, ' ');
4545 if (r->reganch & ROPT_GPOS_SEEN)
4546 PerlIO_printf(Perl_debug_log, "GPOS ");
4547 if (r->reganch & ROPT_SKIP)
4548 PerlIO_printf(Perl_debug_log, "plus ");
4549 if (r->reganch & ROPT_IMPLICIT)
4550 PerlIO_printf(Perl_debug_log, "implicit ");
4551 PerlIO_printf(Perl_debug_log, "minlen %ld ", (long) r->minlen);
4552 if (r->reganch & ROPT_EVAL_SEEN)
4553 PerlIO_printf(Perl_debug_log, "with eval ");
4554 PerlIO_printf(Perl_debug_log, "\n");
4557 U32 len = r->offsets[0];
4558 PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)r->offsets[0]);
4559 for (i = 1; i <= len; i++)
4560 PerlIO_printf(Perl_debug_log, "%"UVuf"[%"UVuf"] ",
4561 (UV)r->offsets[i*2-1],
4562 (UV)r->offsets[i*2]);
4563 PerlIO_printf(Perl_debug_log, "\n");
4565 #endif /* DEBUGGING */
4571 S_put_byte(pTHX_ SV *sv, int c)
4573 if (isCNTRL(c) || c == 255 || !isPRINT(c))
4574 Perl_sv_catpvf(aTHX_ sv, "\\%o", c);
4575 else if (c == '-' || c == ']' || c == '\\' || c == '^')
4576 Perl_sv_catpvf(aTHX_ sv, "\\%c", c);
4578 Perl_sv_catpvf(aTHX_ sv, "%c", c);
4581 #endif /* DEBUGGING */
4584 - regprop - printable representation of opcode
4587 Perl_regprop(pTHX_ SV *sv, regnode *o)
4592 sv_setpvn(sv, "", 0);
4593 if (OP(o) >= reg_num) /* regnode.type is unsigned */
4594 /* It would be nice to FAIL() here, but this may be called from
4595 regexec.c, and it would be hard to supply pRExC_state. */
4596 Perl_croak(aTHX_ "Corrupted regexp opcode");
4597 sv_catpv(sv, (char*)reg_name[OP(o)]); /* Take off const! */
4599 k = PL_regkind[(U8)OP(o)];
4602 SV *dsv = sv_2mortal(newSVpvn("", 0));
4603 /* Using is_utf8_string() is a crude hack but it may
4604 * be the best for now since we have no flag "this EXACTish
4605 * node was UTF-8" --jhi */
4606 bool do_utf8 = is_utf8_string((U8*)STRING(o), STR_LEN(o));
4608 pv_uni_display(dsv, (U8*)STRING(o), STR_LEN(o), 60,
4609 UNI_DISPLAY_REGEX) :
4614 Perl_sv_catpvf(aTHX_ sv, " <%s%.*s%s>",
4619 else if (k == CURLY) {
4620 if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
4621 Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
4622 Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
4624 else if (k == WHILEM && o->flags) /* Ordinal/of */
4625 Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
4626 else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP )
4627 Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o)); /* Parenth number */
4628 else if (k == LOGICAL)
4629 Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* 2: embedded, otherwise 1 */
4630 else if (k == ANYOF) {
4631 int i, rangestart = -1;
4632 U8 flags = ANYOF_FLAGS(o);
4633 const char * const anyofs[] = { /* Should be syncronized with
4634 * ANYOF_ #xdefines in regcomp.h */
4667 if (flags & ANYOF_LOCALE)
4668 sv_catpv(sv, "{loc}");
4669 if (flags & ANYOF_FOLD)
4670 sv_catpv(sv, "{i}");
4671 Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
4672 if (flags & ANYOF_INVERT)
4674 for (i = 0; i <= 256; i++) {
4675 if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
4676 if (rangestart == -1)
4678 } else if (rangestart != -1) {
4679 if (i <= rangestart + 3)
4680 for (; rangestart < i; rangestart++)
4681 put_byte(sv, rangestart);
4683 put_byte(sv, rangestart);
4685 put_byte(sv, i - 1);
4691 if (o->flags & ANYOF_CLASS)
4692 for (i = 0; i < sizeof(anyofs)/sizeof(char*); i++)
4693 if (ANYOF_CLASS_TEST(o,i))
4694 sv_catpv(sv, anyofs[i]);
4696 if (flags & ANYOF_UNICODE)
4697 sv_catpv(sv, "{unicode}");
4698 else if (flags & ANYOF_UNICODE_ALL)
4699 sv_catpv(sv, "{unicode_all}");
4703 SV *sw = regclass_swash(o, FALSE, &lv, 0);
4708 U8 s[UTF8_MAXLEN+1];
4710 for (i = 0; i <= 256; i++) { /* just the first 256 */
4711 U8 *e = uvchr_to_utf8(s, i);
4713 if (i < 256 && swash_fetch(sw, s, TRUE)) {
4714 if (rangestart == -1)
4716 } else if (rangestart != -1) {
4719 if (i <= rangestart + 3)
4720 for (; rangestart < i; rangestart++) {
4721 for(e = uvchr_to_utf8(s, rangestart), p = s; p < e; p++)
4725 for (e = uvchr_to_utf8(s, rangestart), p = s; p < e; p++)
4728 for (e = uvchr_to_utf8(s, i - 1), p = s; p < e; p++)
4735 sv_catpv(sv, "..."); /* et cetera */
4739 char *s = savepv(SvPVX(lv));
4742 while(*s && *s != '\n') s++;
4763 Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
4765 else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
4766 Perl_sv_catpvf(aTHX_ sv, "[-%d]", o->flags);
4767 #endif /* DEBUGGING */
4771 Perl_re_intuit_string(pTHX_ regexp *prog)
4772 { /* Assume that RE_INTUIT is set */
4775 char *s = SvPV(prog->check_substr,n_a);
4777 if (!PL_colorset) reginitcolors();
4778 PerlIO_printf(Perl_debug_log,
4779 "%sUsing REx substr:%s `%s%.60s%s%s'\n",
4780 PL_colors[4],PL_colors[5],PL_colors[0],
4783 (strlen(s) > 60 ? "..." : ""));
4786 return prog->check_substr;
4790 Perl_pregfree(pTHX_ struct regexp *r)
4793 SV *dsv = PERL_DEBUG_PAD_ZERO(0);
4796 if (!r || (--r->refcnt > 0))
4799 char *s = pv_uni_display(dsv, (U8*)r->precomp, r->prelen, 60,
4801 int len = SvCUR(dsv);
4804 PerlIO_printf(Perl_debug_log,
4805 "%sFreeing REx:%s `%s%*.*s%s%s'\n",
4806 PL_colors[4],PL_colors[5],PL_colors[0],
4809 len > 60 ? "..." : "");
4813 Safefree(r->precomp);
4814 if (r->offsets) /* 20010421 MJD */
4815 Safefree(r->offsets);
4816 if (RX_MATCH_COPIED(r))
4817 Safefree(r->subbeg);
4819 if (r->anchored_substr)
4820 SvREFCNT_dec(r->anchored_substr);
4821 if (r->float_substr)
4822 SvREFCNT_dec(r->float_substr);
4823 Safefree(r->substrs);
4826 int n = r->data->count;
4827 AV* new_comppad = NULL;
4832 /* If you add a ->what type here, update the comment in regcomp.h */
4833 switch (r->data->what[n]) {
4835 SvREFCNT_dec((SV*)r->data->data[n]);
4838 Safefree(r->data->data[n]);
4841 new_comppad = (AV*)r->data->data[n];
4844 if (new_comppad == NULL)
4845 Perl_croak(aTHX_ "panic: pregfree comppad");
4846 old_comppad = PL_comppad;
4847 old_curpad = PL_curpad;
4848 /* Watch out for global destruction's random ordering. */
4849 if (SvTYPE(new_comppad) == SVt_PVAV) {
4850 PL_comppad = new_comppad;
4851 PL_curpad = AvARRAY(new_comppad);
4856 if (!OpREFCNT_dec((OP_4tree*)r->data->data[n])) {
4857 op_free((OP_4tree*)r->data->data[n]);
4860 PL_comppad = old_comppad;
4861 PL_curpad = old_curpad;
4862 SvREFCNT_dec((SV*)new_comppad);
4868 Perl_croak(aTHX_ "panic: regfree data code '%c'", r->data->what[n]);
4871 Safefree(r->data->what);
4874 Safefree(r->startp);
4880 - regnext - dig the "next" pointer out of a node
4882 * [Note, when REGALIGN is defined there are two places in regmatch()
4883 * that bypass this code for speed.]
4886 Perl_regnext(pTHX_ register regnode *p)
4888 register I32 offset;
4890 if (p == &PL_regdummy)
4893 offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
4901 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
4904 STRLEN l1 = strlen(pat1);
4905 STRLEN l2 = strlen(pat2);
4914 Copy(pat1, buf, l1 , char);
4915 Copy(pat2, buf + l1, l2 , char);
4916 buf[l1 + l2] = '\n';
4917 buf[l1 + l2 + 1] = '\0';
4919 /* ANSI variant takes additional second argument */
4920 va_start(args, pat2);
4924 msv = vmess(buf, &args);
4926 message = SvPV(msv,l1);
4929 Copy(message, buf, l1 , char);
4930 buf[l1] = '\0'; /* Overwrite \n */
4931 Perl_croak(aTHX_ "%s", buf);
4934 /* XXX Here's a total kludge. But we need to re-enter for swash routines. */
4937 Perl_save_re_context(pTHX)
4940 SAVEPPTR(RExC_precomp); /* uncompiled string. */
4941 SAVEI32(RExC_npar); /* () count. */
4942 SAVEI32(RExC_size); /* Code size. */
4943 SAVEI16(RExC_flags16); /* are we folding, multilining? */
4944 SAVEVPTR(RExC_rx); /* from regcomp.c */
4945 SAVEI32(RExC_seen); /* from regcomp.c */
4946 SAVEI32(RExC_sawback); /* Did we see \1, ...? */
4947 SAVEI32(RExC_naughty); /* How bad is this pattern? */
4948 SAVEVPTR(RExC_emit); /* Code-emit pointer; ®dummy = don't */
4949 SAVEPPTR(RExC_end); /* End of input for compile */
4950 SAVEPPTR(RExC_parse); /* Input-scan pointer. */
4953 SAVEI32(PL_reg_flags); /* from regexec.c */
4955 SAVEPPTR(PL_reginput); /* String-input pointer. */
4956 SAVEPPTR(PL_regbol); /* Beginning of input, for ^ check. */
4957 SAVEPPTR(PL_regeol); /* End of input, for $ check. */
4958 SAVEVPTR(PL_regstartp); /* Pointer to startp array. */
4959 SAVEVPTR(PL_regendp); /* Ditto for endp. */
4960 SAVEVPTR(PL_reglastparen); /* Similarly for lastparen. */
4961 SAVEPPTR(PL_regtill); /* How far we are required to go. */
4962 SAVEGENERICPV(PL_reg_start_tmp); /* from regexec.c */
4963 PL_reg_start_tmp = 0;
4964 SAVEI32(PL_reg_start_tmpl); /* from regexec.c */
4965 PL_reg_start_tmpl = 0;
4966 SAVEVPTR(PL_regdata);
4967 SAVEI32(PL_reg_eval_set); /* from regexec.c */
4968 SAVEI32(PL_regnarrate); /* from regexec.c */
4969 SAVEVPTR(PL_regprogram); /* from regexec.c */
4970 SAVEINT(PL_regindent); /* from regexec.c */
4971 SAVEVPTR(PL_regcc); /* from regexec.c */
4972 SAVEVPTR(PL_curcop);
4973 SAVEVPTR(PL_reg_call_cc); /* from regexec.c */
4974 SAVEVPTR(PL_reg_re); /* from regexec.c */
4975 SAVEPPTR(PL_reg_ganch); /* from regexec.c */
4976 SAVESPTR(PL_reg_sv); /* from regexec.c */
4977 SAVEI8(PL_reg_match_utf8); /* from regexec.c */
4978 SAVEVPTR(PL_reg_magic); /* from regexec.c */
4979 SAVEI32(PL_reg_oldpos); /* from regexec.c */
4980 SAVEVPTR(PL_reg_oldcurpm); /* from regexec.c */
4981 SAVEVPTR(PL_reg_curpm); /* from regexec.c */
4982 SAVEI32(PL_regnpar); /* () count. */
4983 SAVEI32(PL_regsize); /* from regexec.c */
4985 SAVEPPTR(PL_reg_starttry); /* from regexec.c */
4990 clear_re(pTHX_ void *r)
4992 ReREFCNT_dec((regexp *)r);