Context Navigation

regcomp.c @ 20075

Visit:

Revision 20075, 142.9 KB checked in by zacheiss, 21 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r20074, which included commits to RCS files with non-trunk default branches.

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

Note: See TracBrowser for help on using the repository browser.

Context Navigation

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

Download in other formats: