Context Navigation

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

Visit:

Revision 14545, 112.2 KB checked in by ghudson, 25 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r14544, 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-2000, Larry Wall
73	****
74	**** You may distribute under the terms of either the GNU General Public
75	**** License or the Artistic License, as specified in the README file.
76
77	*
78	* Beware that some of this code is subtly aware of the way operator
79	* precedence is structured in regular expressions. Serious changes in
80	* regular-expression syntax might require a total rethink.
81	*/
82	#include "EXTERN.h"
83	#define PERL_IN_REGCOMP_C
84	#include "perl.h"
85
86	#ifdef PERL_IN_XSUB_RE
87	# if defined(PERL_CAPI) \|\| defined(PERL_OBJECT)
88	# include "XSUB.h"
89	# endif
90	#else
91	# include "INTERN.h"
92	#endif
93
94	#define REG_COMP_C
95	#include "regcomp.h"
96
97	#ifdef op
98	#undef op
99	#endif /* op */
100
101	#ifdef MSDOS
102	# if defined(BUGGY_MSC6)
103	/* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
104	# pragma optimize("a",off)
105	/* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
106	# pragma optimize("w",on )
107	# endif /* BUGGY_MSC6 */
108	#endif /* MSDOS */
109
110	#ifndef STATIC
111	#define STATIC static
112	#endif
113
114	#define ISMULT1(c) ((c) == '*' \|\| (c) == '+' \|\| (c) == '?')
115	#define ISMULT2(s) ((s) == '' \|\| (s) == '+' \|\| (s) == '?' \|\| \
116	((*s) == '{' && regcurly(s)))
117	#ifdef atarist
118	#define PERL_META "^$.[()\|?+*\\"
119	#else
120	#define META "^$.[()\|?+*\\"
121	#endif
122
123	#ifdef SPSTART
124	#undef SPSTART /* dratted cpp namespace... */
125	#endif
126	/*
127	* Flags to be passed up and down.
128	*/
129	#define WORST 0 /* Worst case. */
130	#define HASWIDTH 0x1 /* Known to match non-null strings. */
131	#define SIMPLE 0x2 /* Simple enough to be STAR/PLUS operand. */
132	#define SPSTART 0x4 /* Starts with * or +. */
133	#define TRYAGAIN 0x8 /* Weeded out a declaration. */
134
135	/* Length of a variant. */
136
137	typedef struct scan_data_t {
138	I32 len_min;
139	I32 len_delta;
140	I32 pos_min;
141	I32 pos_delta;
142	SV *last_found;
143	I32 last_end; /* min value, <0 unless valid. */
144	I32 last_start_min;
145	I32 last_start_max;
146	SV *longest; / Either &l_fixed, or &l_float. */
147	SV *longest_fixed;
148	I32 offset_fixed;
149	SV *longest_float;
150	I32 offset_float_min;
151	I32 offset_float_max;
152	I32 flags;
153	I32 whilem_c;
154	struct regnode_charclass_class *start_class;
155	} scan_data_t;
156
157	/*
158	* Forward declarations for pregcomp()'s friends.
159	*/
160
161	static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
162	0, 0, 0, 0, 0 };
163
164	#define SF_BEFORE_EOL (SF_BEFORE_SEOL\|SF_BEFORE_MEOL)
165	#define SF_BEFORE_SEOL 0x1
166	#define SF_BEFORE_MEOL 0x2
167	#define SF_FIX_BEFORE_EOL (SF_FIX_BEFORE_SEOL\|SF_FIX_BEFORE_MEOL)
168	#define SF_FL_BEFORE_EOL (SF_FL_BEFORE_SEOL\|SF_FL_BEFORE_MEOL)
169
170	#ifdef NO_UNARY_PLUS
171	# define SF_FIX_SHIFT_EOL (0+2)
172	# define SF_FL_SHIFT_EOL (0+4)
173	#else
174	# define SF_FIX_SHIFT_EOL (+2)
175	# define SF_FL_SHIFT_EOL (+4)
176	#endif
177
178	#define SF_FIX_BEFORE_SEOL (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
179	#define SF_FIX_BEFORE_MEOL (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
180
181	#define SF_FL_BEFORE_SEOL (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
182	#define SF_FL_BEFORE_MEOL (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
183	#define SF_IS_INF 0x40
184	#define SF_HAS_PAR 0x80
185	#define SF_IN_PAR 0x100
186	#define SF_HAS_EVAL 0x200
187	#define SCF_DO_SUBSTR 0x400
188	#define SCF_DO_STCLASS_AND 0x0800
189	#define SCF_DO_STCLASS_OR 0x1000
190	#define SCF_DO_STCLASS (SCF_DO_STCLASS_AND\|SCF_DO_STCLASS_OR)
191
192	#define RF_utf8 8
193	#define UTF (PL_reg_flags & RF_utf8)
194	#define LOC (PL_regflags & PMf_LOCALE)
195	#define FOLD (PL_regflags & PMf_FOLD)
196
197	#define OOB_CHAR8 1234
198	#define OOB_UTF8 123456
199	#define OOB_NAMEDCLASS -1
200
201	#define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
202	#define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
203
204	/* Allow for side effects in s */
205	#define REGC(c,s) STMT_START { if (!SIZE_ONLY) *(s) = (c); else (s);} STMT_END
206
207	static void clear_re(pTHXo_ void *r);
208
209	/* Mark that we cannot extend a found fixed substring at this point.
210	Updata the longest found anchored substring and the longest found
211	floating substrings if needed. */
212
213	STATIC void
214	S_scan_commit(pTHX_ scan_data_t *data)
215	{
216	dTHR;
217	STRLEN l = CHR_SVLEN(data->last_found);
218	STRLEN old_l = CHR_SVLEN(*data->longest);
219
220	if ((l >= old_l) && ((l > old_l) \|\| (data->flags & SF_BEFORE_EOL))) {
221	sv_setsv(*data->longest, data->last_found);
222	if (*data->longest == data->longest_fixed) {
223	data->offset_fixed = l ? data->last_start_min : data->pos_min;
224	if (data->flags & SF_BEFORE_EOL)
225	data->flags
226	\|= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
227	else
228	data->flags &= ~SF_FIX_BEFORE_EOL;
229	}
230	else {
231	data->offset_float_min = l ? data->last_start_min : data->pos_min;
232	data->offset_float_max = (l
233	? data->last_start_max
234	: data->pos_min + data->pos_delta);
235	if (data->flags & SF_BEFORE_EOL)
236	data->flags
237	\|= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
238	else
239	data->flags &= ~SF_FL_BEFORE_EOL;
240	}
241	}
242	SvCUR_set(data->last_found, 0);
243	data->last_end = -1;
244	data->flags &= ~SF_BEFORE_EOL;
245	}
246
247	/* Can match anything (initialization) */
248	STATIC void
249	S_cl_anything(pTHX_ struct regnode_charclass_class *cl)
250	{
251	int value;
252
253	ANYOF_CLASS_ZERO(cl);
254	for (value = 0; value < 256; ++value)
255	ANYOF_BITMAP_SET(cl, value);
256	cl->flags = ANYOF_EOS;
257	if (LOC)
258	cl->flags \|= ANYOF_LOCALE;
259	}
260
261	/* Can match anything (initialization) */
262	STATIC int
263	S_cl_is_anything(pTHX_ struct regnode_charclass_class *cl)
264	{
265	int value;
266
267	for (value = 0; value < ANYOF_MAX; value += 2)
268	if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
269	return 1;
270	for (value = 0; value < 256; ++value)
271	if (!ANYOF_BITMAP_TEST(cl, value))
272	return 0;
273	return 1;
274	}
275
276	/* Can match anything (initialization) */
277	STATIC void
278	S_cl_init(pTHX_ struct regnode_charclass_class *cl)
279	{
280	Zero(cl, 1, struct regnode_charclass_class);
281	cl->type = ANYOF;
282	cl_anything(cl);
283	}
284
285	STATIC void
286	S_cl_init_zero(pTHX_ struct regnode_charclass_class *cl)
287	{
288	Zero(cl, 1, struct regnode_charclass_class);
289	cl->type = ANYOF;
290	cl_anything(cl);
291	if (LOC)
292	cl->flags \|= ANYOF_LOCALE;
293	}
294
295	/* 'And' a given class with another one. Can create false positives */
296	/* We assume that cl is not inverted */
297	STATIC void
298	S_cl_and(pTHX_ struct regnode_charclass_class *cl,
299	struct regnode_charclass_class *and_with)
300	{
301	if (!(and_with->flags & ANYOF_CLASS)
302	&& !(cl->flags & ANYOF_CLASS)
303	&& (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
304	&& !(and_with->flags & ANYOF_FOLD)
305	&& !(cl->flags & ANYOF_FOLD)) {
306	int i;
307
308	if (and_with->flags & ANYOF_INVERT)
309	for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
310	cl->bitmap[i] &= ~and_with->bitmap[i];
311	else
312	for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
313	cl->bitmap[i] &= and_with->bitmap[i];
314	} /* XXXX: logic is complicated otherwise, leave it along for a moment. */
315	if (!(and_with->flags & ANYOF_EOS))
316	cl->flags &= ~ANYOF_EOS;
317	}
318
319	/* 'OR' a given class with another one. Can create false positives */
320	/* We assume that cl is not inverted */
321	STATIC void
322	S_cl_or(pTHX_ struct regnode_charclass_class cl, struct regnode_charclass_class or_with)
323	{
324	if (or_with->flags & ANYOF_INVERT) {
325	/* We do not use
326	* (B1 \| CL1) \| (!B2 & !CL2) = (B1 \| !B2 & !CL2) \| (CL1 \| (!B2 & !CL2))
327	* <= (B1 \| !B2) \| (CL1 \| !CL2)
328	* which is wasteful if CL2 is small, but we ignore CL2:
329	* (B1 \| CL1) \| (!B2 & !CL2) <= (B1 \| CL1) \| !B2 = (B1 \| !B2) \| CL1
330	* XXXX Can we handle case-fold? Unclear:
331	* (OK1(i) \| OK1(i')) \| !(OK1(i) \| OK1(i')) =
332	* (OK1(i) \| OK1(i')) \| (!OK1(i) & !OK1(i'))
333	*/
334	if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
335	&& !(or_with->flags & ANYOF_FOLD)
336	&& !(cl->flags & ANYOF_FOLD) ) {
337	int i;
338
339	for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
340	cl->bitmap[i] \|= ~or_with->bitmap[i];
341	} /* XXXX: logic is complicated otherwise */
342	else {
343	cl_anything(cl);
344	}
345	} else {
346	/* (B1 \| CL1) \| (B2 \| CL2) = (B1 \| B2) \| (CL1 \| CL2)) */
347	if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
348	&& (!(or_with->flags & ANYOF_FOLD)
349	\|\| (cl->flags & ANYOF_FOLD)) ) {
350	int i;
351
352	/* OR char bitmap and class bitmap separately */
353	for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
354	cl->bitmap[i] \|= or_with->bitmap[i];
355	if (or_with->flags & ANYOF_CLASS) {
356	for (i = 0; i < ANYOF_CLASSBITMAP_SIZE; i++)
357	cl->classflags[i] \|= or_with->classflags[i];
358	cl->flags \|= ANYOF_CLASS;
359	}
360	}
361	else { /* XXXX: logic is complicated, leave it along for a moment. */
362	cl_anything(cl);
363	}
364	}
365	if (or_with->flags & ANYOF_EOS)
366	cl->flags \|= ANYOF_EOS;
367	}
368
369	/* REx optimizer. Converts nodes into quickier variants "in place".
370	Finds fixed substrings. */
371
372	/* Stops at toplevel WHILEM as well as at `last'. At end *scanp is set
373	to the position after last scanned or to NULL. */
374
375	STATIC I32
376	S_study_chunk(pTHX_ regnode *scanp, I32 deltap, regnode last, scan_data_t data, U32 flags)
377	/* scanp: Start here (read-write). */
378	/* deltap: Write maxlen-minlen here. */
379	/* last: Stop before this one. */
380	{
381	dTHR;
382	I32 min = 0, pars = 0, code;
383	regnode scan = scanp, *next;
384	I32 delta = 0;
385	int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
386	int is_inf_internal = 0; /* The studied chunk is infinite */
387	I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
388	scan_data_t data_fake;
389	struct regnode_charclass_class and_with; /* Valid if flags & SCF_DO_STCLASS_OR */
390
391	while (scan && OP(scan) != END && scan < last) {
392	/* Peephole optimizer: */
393
394	if (PL_regkind[(U8)OP(scan)] == EXACT) {
395	/* Merge several consecutive EXACTish nodes into one. */
396	regnode *n = regnext(scan);
397	U32 stringok = 1;
398	#ifdef DEBUGGING
399	regnode *stop = scan;
400	#endif
401
402	next = scan + NODE_SZ_STR(scan);
403	/* Skip NOTHING, merge EXACT. /
404	while (n &&
405	( PL_regkind[(U8)OP(n)] == NOTHING \|\|
406	(stringok && (OP(n) == OP(scan))))
407	&& NEXT_OFF(n)
408	&& NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX) {
409	if (OP(n) == TAIL \|\| n > next)
410	stringok = 0;
411	if (PL_regkind[(U8)OP(n)] == NOTHING) {
412	NEXT_OFF(scan) += NEXT_OFF(n);
413	next = n + NODE_STEP_REGNODE;
414	#ifdef DEBUGGING
415	if (stringok)
416	stop = n;
417	#endif
418	n = regnext(n);
419	}
420	else {
421	int oldl = STR_LEN(scan);
422	regnode *nnext = regnext(n);
423
424	if (oldl + STR_LEN(n) > U8_MAX)
425	break;
426	NEXT_OFF(scan) += NEXT_OFF(n);
427	STR_LEN(scan) += STR_LEN(n);
428	next = n + NODE_SZ_STR(n);
429	/* Now we can overwrite n : /
430	Move(STRING(n), STRING(scan) + oldl,
431	STR_LEN(n), char);
432	#ifdef DEBUGGING
433	if (stringok)
434	stop = next - 1;
435	#endif
436	n = nnext;
437	}
438	}
439	#ifdef DEBUGGING
440	/* Allow dumping */
441	n = scan + NODE_SZ_STR(scan);
442	while (n <= stop) {
443	if (PL_regkind[(U8)OP(n)] != NOTHING \|\| OP(n) == NOTHING) {
444	OP(n) = OPTIMIZED;
445	NEXT_OFF(n) = 0;
446	}
447	n++;
448	}
449	#endif
450	}
451	/* Follow the next-chain of the current node and optimize
452	away all the NOTHINGs from it. */
453	if (OP(scan) != CURLYX) {
454	int max = (reg_off_by_arg[OP(scan)]
455	? I32_MAX
456	/* I32 may be smaller than U16 on CRAYs! */
457	: (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
458	int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
459	int noff;
460	regnode *n = scan;
461
462	/* Skip NOTHING and LONGJMP. */
463	while ((n = regnext(n))
464	&& ((PL_regkind[(U8)OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
465	\|\| ((OP(n) == LONGJMP) && (noff = ARG(n))))
466	&& off + noff < max)
467	off += noff;
468	if (reg_off_by_arg[OP(scan)])
469	ARG(scan) = off;
470	else
471	NEXT_OFF(scan) = off;
472	}
473	/* The principal pseudo-switch. Cannot be a switch, since we
474	look into several different things. */
475	if (OP(scan) == BRANCH \|\| OP(scan) == BRANCHJ
476	\|\| OP(scan) == IFTHEN \|\| OP(scan) == SUSPEND) {
477	next = regnext(scan);
478	code = OP(scan);
479
480	if (OP(next) == code \|\| code == IFTHEN \|\| code == SUSPEND) {
481	I32 max1 = 0, min1 = I32_MAX, num = 0;
482	struct regnode_charclass_class accum;
483
484	if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
485	scan_commit(data); /* Cannot merge strings after this. */
486	if (flags & SCF_DO_STCLASS)
487	cl_init_zero(&accum);
488	while (OP(scan) == code) {
489	I32 deltanext, minnext, f = 0;
490	struct regnode_charclass_class this_class;
491
492	num++;
493	data_fake.flags = 0;
494	if (data)
495	data_fake.whilem_c = data->whilem_c;
496	next = regnext(scan);
497	scan = NEXTOPER(scan);
498	if (code != BRANCH)
499	scan = NEXTOPER(scan);
500	if (flags & SCF_DO_STCLASS) {
501	cl_init(&this_class);
502	data_fake.start_class = &this_class;
503	f = SCF_DO_STCLASS_AND;
504	}
505	/* we suppose the run is continuous, last=next...*/
506	minnext = study_chunk(&scan, &deltanext, next,
507	&data_fake, f);
508	if (min1 > minnext)
509	min1 = minnext;
510	if (max1 < minnext + deltanext)
511	max1 = minnext + deltanext;
512	if (deltanext == I32_MAX)
513	is_inf = is_inf_internal = 1;
514	scan = next;
515	if (data_fake.flags & (SF_HAS_PAR\|SF_IN_PAR))
516	pars++;
517	if (data && (data_fake.flags & SF_HAS_EVAL))
518	data->flags \|= SF_HAS_EVAL;
519	if (data)
520	data->whilem_c = data_fake.whilem_c;
521	if (flags & SCF_DO_STCLASS)
522	cl_or(&accum, &this_class);
523	if (code == SUSPEND)
524	break;
525	}
526	if (code == IFTHEN && num < 2) /* Empty ELSE branch */
527	min1 = 0;
528	if (flags & SCF_DO_SUBSTR) {
529	data->pos_min += min1;
530	data->pos_delta += max1 - min1;
531	if (max1 != min1 \|\| is_inf)
532	data->longest = &(data->longest_float);
533	}
534	min += min1;
535	delta += max1 - min1;
536	if (flags & SCF_DO_STCLASS_OR) {
537	cl_or(data->start_class, &accum);
538	if (min1) {
539	cl_and(data->start_class, &and_with);
540	flags &= ~SCF_DO_STCLASS;
541	}
542	}
543	else if (flags & SCF_DO_STCLASS_AND) {
544	if (min1) {
545	cl_and(data->start_class, &accum);
546	flags &= ~SCF_DO_STCLASS;
547	}
548	else {
549	/* Switch to OR mode: cache the old value of
550	* data->start_class */
551	StructCopy(data->start_class, &and_with,
552	struct regnode_charclass_class);
553	flags &= ~SCF_DO_STCLASS_AND;
554	StructCopy(&accum, data->start_class,
555	struct regnode_charclass_class);
556	flags \|= SCF_DO_STCLASS_OR;
557	data->start_class->flags \|= ANYOF_EOS;
558	}
559	}
560	}
561	else if (code == BRANCHJ) /* single branch is optimized. */
562	scan = NEXTOPER(NEXTOPER(scan));
563	else /* single branch is optimized. */
564	scan = NEXTOPER(scan);
565	continue;
566	}
567	else if (OP(scan) == EXACT) {
568	I32 l = STR_LEN(scan);
569	if (UTF) {
570	unsigned char s = (unsigned char )STRING(scan);
571	unsigned char *e = s + l;
572	I32 newl = 0;
573	while (s < e) {
574	newl++;
575	s += UTF8SKIP(s);
576	}
577	l = newl;
578	}
579	min += l;
580	if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
581	/* The code below prefers earlier match for fixed
582	offset, later match for variable offset. */
583	if (data->last_end == -1) { /* Update the start info. */
584	data->last_start_min = data->pos_min;
585	data->last_start_max = is_inf
586	? I32_MAX : data->pos_min + data->pos_delta;
587	}
588	sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
589	data->last_end = data->pos_min + l;
590	data->pos_min += l; /* As in the first entry. */
591	data->flags &= ~SF_BEFORE_EOL;
592	}
593	if (flags & SCF_DO_STCLASS_AND) {
594	/* Check whether it is compatible with what we know already! */
595	int compat = 1;
596
597	if (!(data->start_class->flags & (ANYOF_CLASS \| ANYOF_LOCALE))
598	&& !ANYOF_BITMAP_TEST(data->start_class, *STRING(scan))
599	&& (!(data->start_class->flags & ANYOF_FOLD)
600	\|\| !ANYOF_BITMAP_TEST(data->start_class,
601	PL_fold[(U8)STRING(scan)])))
602	compat = 0;
603	ANYOF_CLASS_ZERO(data->start_class);
604	ANYOF_BITMAP_ZERO(data->start_class);
605	if (compat)
606	ANYOF_BITMAP_SET(data->start_class, *STRING(scan));
607	data->start_class->flags &= ~ANYOF_EOS;
608	}
609	else if (flags & SCF_DO_STCLASS_OR) {
610	/* false positive possible if the class is case-folded */
611	ANYOF_BITMAP_SET(data->start_class, *STRING(scan));
612	data->start_class->flags &= ~ANYOF_EOS;
613	cl_and(data->start_class, &and_with);
614	}
615	flags &= ~SCF_DO_STCLASS;
616	}
617	else if (PL_regkind[(U8)OP(scan)] == EXACT) { /* But OP != EXACT! */
618	I32 l = STR_LEN(scan);
619
620	/* Search for fixed substrings supports EXACT only. */
621	if (flags & SCF_DO_SUBSTR)
622	scan_commit(data);
623	if (UTF) {
624	unsigned char s = (unsigned char )STRING(scan);
625	unsigned char *e = s + l;
626	I32 newl = 0;
627	while (s < e) {
628	newl++;
629	s += UTF8SKIP(s);
630	}
631	l = newl;
632	}
633	min += l;
634	if (data && (flags & SCF_DO_SUBSTR))
635	data->pos_min += l;
636	if (flags & SCF_DO_STCLASS_AND) {
637	/* Check whether it is compatible with what we know already! */
638	int compat = 1;
639
640	if (!(data->start_class->flags & (ANYOF_CLASS \| ANYOF_LOCALE))
641	&& !ANYOF_BITMAP_TEST(data->start_class, *STRING(scan))
642	&& !ANYOF_BITMAP_TEST(data->start_class,
643	PL_fold[(U8)STRING(scan)]))
644	compat = 0;
645	ANYOF_CLASS_ZERO(data->start_class);
646	ANYOF_BITMAP_ZERO(data->start_class);
647	if (compat) {
648	ANYOF_BITMAP_SET(data->start_class, *STRING(scan));
649	data->start_class->flags &= ~ANYOF_EOS;
650	data->start_class->flags \|= ANYOF_FOLD;
651	if (OP(scan) == EXACTFL)
652	data->start_class->flags \|= ANYOF_LOCALE;
653	}
654	}
655	else if (flags & SCF_DO_STCLASS_OR) {
656	if (data->start_class->flags & ANYOF_FOLD) {
657	/* false positive possible if the class is case-folded.
658	Assume that the locale settings are the same... */
659	ANYOF_BITMAP_SET(data->start_class, *STRING(scan));
660	data->start_class->flags &= ~ANYOF_EOS;
661	}
662	cl_and(data->start_class, &and_with);
663	}
664	flags &= ~SCF_DO_STCLASS;
665	}
666	else if (strchr((char*)PL_varies,OP(scan))) {
667	I32 mincount, maxcount, minnext, deltanext, pos_before, fl;
668	I32 f = flags;
669	regnode *oscan = scan;
670	struct regnode_charclass_class this_class;
671	struct regnode_charclass_class *oclass = NULL;
672
673	switch (PL_regkind[(U8)OP(scan)]) {
674	case WHILEM: /* End of (?:...)* . */
675	scan = NEXTOPER(scan);
676	goto finish;
677	case PLUS:
678	if (flags & (SCF_DO_SUBSTR \| SCF_DO_STCLASS)) {
679	next = NEXTOPER(scan);
680	if (OP(next) == EXACT \|\| (flags & SCF_DO_STCLASS)) {
681	mincount = 1;
682	maxcount = REG_INFTY;
683	next = regnext(scan);
684	scan = NEXTOPER(scan);
685	goto do_curly;
686	}
687	}
688	if (flags & SCF_DO_SUBSTR)
689	data->pos_min++;
690	min++;
691	/* Fall through. */
692	case STAR:
693	if (flags & SCF_DO_STCLASS) {
694	mincount = 0;
695	maxcount = REG_INFTY;
696	next = regnext(scan);
697	scan = NEXTOPER(scan);
698	goto do_curly;
699	}
700	is_inf = is_inf_internal = 1;
701	scan = regnext(scan);
702	if (flags & SCF_DO_SUBSTR) {
703	scan_commit(data); /* Cannot extend fixed substrings */
704	data->longest = &(data->longest_float);
705	}
706	goto optimize_curly_tail;
707	case CURLY:
708	mincount = ARG1(scan);
709	maxcount = ARG2(scan);
710	next = regnext(scan);
711	scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
712	do_curly:
713	if (flags & SCF_DO_SUBSTR) {
714	if (mincount == 0) scan_commit(data); /* Cannot extend fixed substrings */
715	pos_before = data->pos_min;
716	}
717	if (data) {
718	fl = data->flags;
719	data->flags &= ~(SF_HAS_PAR\|SF_IN_PAR\|SF_HAS_EVAL);
720	if (is_inf)
721	data->flags \|= SF_IS_INF;
722	}
723	if (flags & SCF_DO_STCLASS) {
724	cl_init(&this_class);
725	oclass = data->start_class;
726	data->start_class = &this_class;
727	f \|= SCF_DO_STCLASS_AND;
728	f &= ~SCF_DO_STCLASS_OR;
729	}
730
731	/* This will finish on WHILEM, setting scan, or on NULL: */
732	minnext = study_chunk(&scan, &deltanext, last, data,
733	mincount == 0
734	? (f & ~SCF_DO_SUBSTR) : f);
735
736	if (flags & SCF_DO_STCLASS)
737	data->start_class = oclass;
738	if (mincount == 0 \|\| minnext == 0) {
739	if (flags & SCF_DO_STCLASS_OR) {
740	cl_or(data->start_class, &this_class);
741	}
742	else if (flags & SCF_DO_STCLASS_AND) {
743	/* Switch to OR mode: cache the old value of
744	* data->start_class */
745	StructCopy(data->start_class, &and_with,
746	struct regnode_charclass_class);
747	flags &= ~SCF_DO_STCLASS_AND;
748	StructCopy(&this_class, data->start_class,
749	struct regnode_charclass_class);
750	flags \|= SCF_DO_STCLASS_OR;
751	data->start_class->flags \|= ANYOF_EOS;
752	}
753	} else { /* Non-zero len */
754	if (flags & SCF_DO_STCLASS_OR) {
755	cl_or(data->start_class, &this_class);
756	cl_and(data->start_class, &and_with);
757	}
758	else if (flags & SCF_DO_STCLASS_AND)
759	cl_and(data->start_class, &this_class);
760	flags &= ~SCF_DO_STCLASS;
761	}
762	if (!scan) /* It was not CURLYX, but CURLY. */
763	scan = next;
764	if (ckWARN(WARN_REGEXP) && (minnext + deltanext == 0)
765	&& !(data->flags & (SF_HAS_PAR\|SF_IN_PAR))
766	&& maxcount <= REG_INFTY/3) /* Complement check for big count */
767	Perl_warner(aTHX_ WARN_REGEXP,
768	"Strange *+?{} on zero-length expression");
769	min += minnext * mincount;
770	is_inf_internal \|= ((maxcount == REG_INFTY
771	&& (minnext + deltanext) > 0)
772	\|\| deltanext == I32_MAX);
773	is_inf \|= is_inf_internal;
774	delta += (minnext + deltanext) * maxcount - minnext * mincount;
775
776	/* Try powerful optimization CURLYX => CURLYN. */
777	if ( OP(oscan) == CURLYX && data
778	&& data->flags & SF_IN_PAR
779	&& !(data->flags & SF_HAS_EVAL)
780	&& !deltanext && minnext == 1 ) {
781	/* Try to optimize to CURLYN. */
782	regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
783	regnode nxt1 = nxt, nxt2;
784
785	/* Skip open. */
786	nxt = regnext(nxt);
787	if (!strchr((char*)PL_simple,OP(nxt))
788	&& !(PL_regkind[(U8)OP(nxt)] == EXACT
789	&& STR_LEN(nxt) == 1))
790	goto nogo;
791	nxt2 = nxt;
792	nxt = regnext(nxt);
793	if (OP(nxt) != CLOSE)
794	goto nogo;
795	/* Now we know that nxt2 is the only contents: */
796	oscan->flags = ARG(nxt);
797	OP(oscan) = CURLYN;
798	OP(nxt1) = NOTHING; /* was OPEN. */
799	#ifdef DEBUGGING
800	OP(nxt1 + 1) = OPTIMIZED; /* was count. */
801	NEXT_OFF(nxt1+ 1) = 0; /* just for consistancy. */
802	NEXT_OFF(nxt2) = 0; /* just for consistancy with CURLY. */
803	OP(nxt) = OPTIMIZED; /* was CLOSE. */
804	OP(nxt + 1) = OPTIMIZED; /* was count. */
805	NEXT_OFF(nxt+ 1) = 0; /* just for consistancy. */
806	#endif
807	}
808	nogo:
809
810	/* Try optimization CURLYX => CURLYM. */
811	if ( OP(oscan) == CURLYX && data
812	&& !(data->flags & SF_HAS_PAR)
813	&& !(data->flags & SF_HAS_EVAL)
814	&& !deltanext ) {
815	/* XXXX How to optimize if data == 0? */
816	/* Optimize to a simpler form. */
817	regnode nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; / OPEN */
818	regnode *nxt2;
819
820	OP(oscan) = CURLYM;
821	while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
822	&& (OP(nxt2) != WHILEM))
823	nxt = nxt2;
824	OP(nxt2) = SUCCEED; /* Whas WHILEM */
825	/* Need to optimize away parenths. */
826	if (data->flags & SF_IN_PAR) {
827	/* Set the parenth number. */
828	regnode nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; / OPEN*/
829
830	if (OP(nxt) != CLOSE)
831	FAIL("panic opt close");
832	oscan->flags = ARG(nxt);
833	OP(nxt1) = OPTIMIZED; /* was OPEN. */
834	OP(nxt) = OPTIMIZED; /* was CLOSE. */
835	#ifdef DEBUGGING
836	OP(nxt1 + 1) = OPTIMIZED; /* was count. */
837	OP(nxt + 1) = OPTIMIZED; /* was count. */
838	NEXT_OFF(nxt1 + 1) = 0; /* just for consistancy. */
839	NEXT_OFF(nxt + 1) = 0; /* just for consistancy. */
840	#endif
841	#if 0
842	while ( nxt1 && (OP(nxt1) != WHILEM)) {
843	regnode *nnxt = regnext(nxt1);
844
845	if (nnxt == nxt) {
846	if (reg_off_by_arg[OP(nxt1)])
847	ARG_SET(nxt1, nxt2 - nxt1);
848	else if (nxt2 - nxt1 < U16_MAX)
849	NEXT_OFF(nxt1) = nxt2 - nxt1;
850	else
851	OP(nxt) = NOTHING; /* Cannot beautify */
852	}
853	nxt1 = nnxt;
854	}
855	#endif
856	/* Optimize again: */
857	study_chunk(&nxt1, &deltanext, nxt, NULL, 0);
858	}
859	else
860	oscan->flags = 0;
861	}
862	else if (OP(oscan) == CURLYX && data && ++data->whilem_c < 16) {
863	/* This stays as CURLYX, and can put the count/of pair. */
864	/* Find WHILEM (as in regexec.c) */
865	regnode *nxt = oscan + NEXT_OFF(oscan);
866
867	if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
868	nxt += ARG(nxt);
869	PREVOPER(nxt)->flags = data->whilem_c
870	\| (PL_reg_whilem_seen << 4); /* On WHILEM */
871	}
872	if (data && fl & (SF_HAS_PAR\|SF_IN_PAR))
873	pars++;
874	if (flags & SCF_DO_SUBSTR) {
875	SV *last_str = Nullsv;
876	int counted = mincount != 0;
877
878	if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
879	I32 b = pos_before >= data->last_start_min
880	? pos_before : data->last_start_min;
881	STRLEN l;
882	char *s = SvPV(data->last_found, l);
883	I32 old = b - data->last_start_min;
884
885	if (UTF)
886	old = utf8_hop((U8)s, old) - (U8)s;
887
888	l -= old;
889	/* Get the added string: */
890	last_str = newSVpvn(s + old, l);
891	if (deltanext == 0 && pos_before == b) {
892	/* What was added is a constant string */
893	if (mincount > 1) {
894	SvGROW(last_str, (mincount * l) + 1);
895	repeatcpy(SvPVX(last_str) + l,
896	SvPVX(last_str), l, mincount - 1);
897	SvCUR(last_str) *= mincount;
898	/* Add additional parts. */
899	SvCUR_set(data->last_found,
900	SvCUR(data->last_found) - l);
901	sv_catsv(data->last_found, last_str);
902	data->last_end += l * (mincount - 1);
903	}
904	}
905	}
906	/* It is counted once already... */
907	data->pos_min += minnext * (mincount - counted);
908	data->pos_delta += - counted * deltanext +
909	(minnext + deltanext) * maxcount - minnext * mincount;
910	if (mincount != maxcount) {
911	/* Cannot extend fixed substrings found inside
912	the group. */
913	scan_commit(data);
914	if (mincount && last_str) {
915	sv_setsv(data->last_found, last_str);
916	data->last_end = data->pos_min;
917	data->last_start_min =
918	data->pos_min - CHR_SVLEN(last_str);
919	data->last_start_max = is_inf
920	? I32_MAX
921	: data->pos_min + data->pos_delta
922	- CHR_SVLEN(last_str);
923	}
924	data->longest = &(data->longest_float);
925	}
926	SvREFCNT_dec(last_str);
927	}
928	if (data && (fl & SF_HAS_EVAL))
929	data->flags \|= SF_HAS_EVAL;
930	optimize_curly_tail:
931	if (OP(oscan) != CURLYX) {
932	while (PL_regkind[(U8)OP(next = regnext(oscan))] == NOTHING
933	&& NEXT_OFF(next))
934	NEXT_OFF(oscan) += NEXT_OFF(next);
935	}
936	continue;
937	default: /* REF and CLUMP only? */
938	if (flags & SCF_DO_SUBSTR) {
939	scan_commit(data); /* Cannot expect anything... */
940	data->longest = &(data->longest_float);
941	}
942	is_inf = is_inf_internal = 1;
943	if (flags & SCF_DO_STCLASS_OR)
944	cl_anything(data->start_class);
945	flags &= ~SCF_DO_STCLASS;
946	break;
947	}
948	}
949	else if (strchr((char*)PL_simple,OP(scan)) \|\| PL_regkind[(U8)OP(scan)] == ANYUTF8) {
950	int value;
951
952	if (flags & SCF_DO_SUBSTR) {
953	scan_commit(data);
954	data->pos_min++;
955	}
956	min++;
957	if (flags & SCF_DO_STCLASS) {
958	data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
959
960	/* Some of the logic below assumes that switching
961	locale on will only add false positives. */
962	switch (PL_regkind[(U8)OP(scan)]) {
963	case ANYUTF8:
964	case SANY:
965	case SANYUTF8:
966	case ALNUMUTF8:
967	case ANYOFUTF8:
968	case ALNUMLUTF8:
969	case NALNUMUTF8:
970	case NALNUMLUTF8:
971	case SPACEUTF8:
972	case NSPACEUTF8:
973	case SPACELUTF8:
974	case NSPACELUTF8:
975	case DIGITUTF8:
976	case NDIGITUTF8:
977	default:
978	do_default:
979	/* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
980	if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
981	cl_anything(data->start_class);
982	break;
983	case REG_ANY:
984	if (OP(scan) == SANY)
985	goto do_default;
986	if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
987	value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
988	\|\| (data->start_class->flags & ANYOF_CLASS));
989	cl_anything(data->start_class);
990	}
991	if (flags & SCF_DO_STCLASS_AND \|\| !value)
992	ANYOF_BITMAP_CLEAR(data->start_class,'\n');
993	break;
994	case ANYOF:
995	if (flags & SCF_DO_STCLASS_AND)
996	cl_and(data->start_class,
997	(struct regnode_charclass_class*)scan);
998	else
999	cl_or(data->start_class,
1000	(struct regnode_charclass_class*)scan);
1001	break;
1002	case ALNUM:
1003	if (flags & SCF_DO_STCLASS_AND) {
1004	if (!(data->start_class->flags & ANYOF_LOCALE)) {
1005	ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
1006	for (value = 0; value < 256; value++)
1007	if (!isALNUM(value))
1008	ANYOF_BITMAP_CLEAR(data->start_class, value);
1009	}
1010	}
1011	else {
1012	if (data->start_class->flags & ANYOF_LOCALE)
1013	ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
1014	else {
1015	for (value = 0; value < 256; value++)
1016	if (isALNUM(value))
1017	ANYOF_BITMAP_SET(data->start_class, value);
1018	}
1019	}
1020	break;
1021	case ALNUML:
1022	if (flags & SCF_DO_STCLASS_AND) {
1023	if (data->start_class->flags & ANYOF_LOCALE)
1024	ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
1025	}
1026	else {
1027	ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
1028	data->start_class->flags \|= ANYOF_LOCALE;
1029	}
1030	break;
1031	case NALNUM:
1032	if (flags & SCF_DO_STCLASS_AND) {
1033	if (!(data->start_class->flags & ANYOF_LOCALE)) {
1034	ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
1035	for (value = 0; value < 256; value++)
1036	if (isALNUM(value))
1037	ANYOF_BITMAP_CLEAR(data->start_class, value);
1038	}
1039	}
1040	else {
1041	if (data->start_class->flags & ANYOF_LOCALE)
1042	ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
1043	else {
1044	for (value = 0; value < 256; value++)
1045	if (!isALNUM(value))
1046	ANYOF_BITMAP_SET(data->start_class, value);
1047	}
1048	}
1049	break;
1050	case NALNUML:
1051	if (flags & SCF_DO_STCLASS_AND) {
1052	if (data->start_class->flags & ANYOF_LOCALE)
1053	ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
1054	}
1055	else {
1056	data->start_class->flags \|= ANYOF_LOCALE;
1057	ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
1058	}
1059	break;
1060	case SPACE:
1061	if (flags & SCF_DO_STCLASS_AND) {
1062	if (!(data->start_class->flags & ANYOF_LOCALE)) {
1063	ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
1064	for (value = 0; value < 256; value++)
1065	if (!isSPACE(value))
1066	ANYOF_BITMAP_CLEAR(data->start_class, value);
1067	}
1068	}
1069	else {
1070	if (data->start_class->flags & ANYOF_LOCALE)
1071	ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
1072	else {
1073	for (value = 0; value < 256; value++)
1074	if (isSPACE(value))
1075	ANYOF_BITMAP_SET(data->start_class, value);
1076	}
1077	}
1078	break;
1079	case SPACEL:
1080	if (flags & SCF_DO_STCLASS_AND) {
1081	if (data->start_class->flags & ANYOF_LOCALE)
1082	ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
1083	}
1084	else {
1085	data->start_class->flags \|= ANYOF_LOCALE;
1086	ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
1087	}
1088	break;
1089	case NSPACE:
1090	if (flags & SCF_DO_STCLASS_AND) {
1091	if (!(data->start_class->flags & ANYOF_LOCALE)) {
1092	ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
1093	for (value = 0; value < 256; value++)
1094	if (isSPACE(value))
1095	ANYOF_BITMAP_CLEAR(data->start_class, value);
1096	}
1097	}
1098	else {
1099	if (data->start_class->flags & ANYOF_LOCALE)
1100	ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
1101	else {
1102	for (value = 0; value < 256; value++)
1103	if (!isSPACE(value))
1104	ANYOF_BITMAP_SET(data->start_class, value);
1105	}
1106	}
1107	break;
1108	case NSPACEL:
1109	if (flags & SCF_DO_STCLASS_AND) {
1110	if (data->start_class->flags & ANYOF_LOCALE) {
1111	ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
1112	for (value = 0; value < 256; value++)
1113	if (!isSPACE(value))
1114	ANYOF_BITMAP_CLEAR(data->start_class, value);
1115	}
1116	}
1117	else {
1118	data->start_class->flags \|= ANYOF_LOCALE;
1119	ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
1120	}
1121	break;
1122	case DIGIT:
1123	if (flags & SCF_DO_STCLASS_AND) {
1124	ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT);
1125	for (value = 0; value < 256; value++)
1126	if (!isDIGIT(value))
1127	ANYOF_BITMAP_CLEAR(data->start_class, value);
1128	}
1129	else {
1130	if (data->start_class->flags & ANYOF_LOCALE)
1131	ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT);
1132	else {
1133	for (value = 0; value < 256; value++)
1134	if (isDIGIT(value))
1135	ANYOF_BITMAP_SET(data->start_class, value);
1136	}
1137	}
1138	break;
1139	case NDIGIT:
1140	if (flags & SCF_DO_STCLASS_AND) {
1141	ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT);
1142	for (value = 0; value < 256; value++)
1143	if (isDIGIT(value))
1144	ANYOF_BITMAP_CLEAR(data->start_class, value);
1145	}
1146	else {
1147	if (data->start_class->flags & ANYOF_LOCALE)
1148	ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT);
1149	else {
1150	for (value = 0; value < 256; value++)
1151	if (!isDIGIT(value))
1152	ANYOF_BITMAP_SET(data->start_class, value);
1153	}
1154	}
1155	break;
1156	}
1157	if (flags & SCF_DO_STCLASS_OR)
1158	cl_and(data->start_class, &and_with);
1159	flags &= ~SCF_DO_STCLASS;
1160	}
1161	}
1162	else if (PL_regkind[(U8)OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
1163	data->flags \|= (OP(scan) == MEOL
1164	? SF_BEFORE_MEOL
1165	: SF_BEFORE_SEOL);
1166	}
1167	else if ( PL_regkind[(U8)OP(scan)] == BRANCHJ
1168	/* Lookbehind, or need to calculate parens/evals/stclass: */
1169	&& (scan->flags \|\| data \|\| (flags & SCF_DO_STCLASS))
1170	&& (OP(scan) == IFMATCH \|\| OP(scan) == UNLESSM)) {
1171	/* Lookahead/lookbehind */
1172	I32 deltanext, minnext;
1173	regnode *nscan;
1174	struct regnode_charclass_class intrnl;
1175	int f = 0;
1176
1177	data_fake.flags = 0;
1178	if (data)
1179	data_fake.whilem_c = data->whilem_c;
1180	if ( flags & SCF_DO_STCLASS && !scan->flags
1181	&& OP(scan) == IFMATCH ) { /* Lookahead */
1182	cl_init(&intrnl);
1183	data_fake.start_class = &intrnl;
1184	f = SCF_DO_STCLASS_AND;
1185	}
1186	next = regnext(scan);
1187	nscan = NEXTOPER(NEXTOPER(scan));
1188	minnext = study_chunk(&nscan, &deltanext, last, &data_fake, f);
1189	if (scan->flags) {
1190	if (deltanext) {
1191	FAIL("variable length lookbehind not implemented");
1192	}
1193	else if (minnext > U8_MAX) {
1194	FAIL2("lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
1195	}
1196	scan->flags = minnext;
1197	}
1198	if (data && data_fake.flags & (SF_HAS_PAR\|SF_IN_PAR))
1199	pars++;
1200	if (data && (data_fake.flags & SF_HAS_EVAL))
1201	data->flags \|= SF_HAS_EVAL;
1202	if (data)
1203	data->whilem_c = data_fake.whilem_c;
1204	if (f) {
1205	int was = (data->start_class->flags & ANYOF_EOS);
1206
1207	cl_and(data->start_class, &intrnl);
1208	if (was)
1209	data->start_class->flags \|= ANYOF_EOS;
1210	}
1211	}
1212	else if (OP(scan) == OPEN) {
1213	pars++;
1214	}
1215	else if (OP(scan) == CLOSE && ARG(scan) == is_par) {
1216	next = regnext(scan);
1217
1218	if ( next && (OP(next) != WHILEM) && next < last)
1219	is_par = 0; /* Disable optimization */
1220	}
1221	else if (OP(scan) == EVAL) {
1222	if (data)
1223	data->flags \|= SF_HAS_EVAL;
1224	}
1225	else if (OP(scan) == LOGICAL && scan->flags == 2) { /* Embedded follows */
1226	if (flags & SCF_DO_SUBSTR) {
1227	scan_commit(data);
1228	data->longest = &(data->longest_float);
1229	}
1230	is_inf = is_inf_internal = 1;
1231	if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
1232	cl_anything(data->start_class);
1233	flags &= ~SCF_DO_STCLASS;
1234	}
1235	/* Else: zero-length, ignore. */
1236	scan = regnext(scan);
1237	}
1238
1239	finish:
1240	*scanp = scan;
1241	*deltap = is_inf_internal ? I32_MAX : delta;
1242	if (flags & SCF_DO_SUBSTR && is_inf)
1243	data->pos_delta = I32_MAX - data->pos_min;
1244	if (is_par > U8_MAX)
1245	is_par = 0;
1246	if (is_par && pars==1 && data) {
1247	data->flags \|= SF_IN_PAR;
1248	data->flags &= ~SF_HAS_PAR;
1249	}
1250	else if (pars && data) {
1251	data->flags \|= SF_HAS_PAR;
1252	data->flags &= ~SF_IN_PAR;
1253	}
1254	if (flags & SCF_DO_STCLASS_OR)
1255	cl_and(data->start_class, &and_with);
1256	return min;
1257	}
1258
1259	STATIC I32
1260	S_add_data(pTHX_ I32 n, char *s)
1261	{
1262	dTHR;
1263	if (PL_regcomp_rx->data) {
1264	Renewc(PL_regcomp_rx->data,
1265	sizeof(PL_regcomp_rx->data) + sizeof(void) * (PL_regcomp_rx->data->count + n - 1),
1266	char, struct reg_data);
1267	Renew(PL_regcomp_rx->data->what, PL_regcomp_rx->data->count + n, U8);
1268	PL_regcomp_rx->data->count += n;
1269	}
1270	else {
1271	Newc(1207, PL_regcomp_rx->data, sizeof(PL_regcomp_rx->data) + sizeof(void) * (n - 1),
1272	char, struct reg_data);
1273	New(1208, PL_regcomp_rx->data->what, n, U8);
1274	PL_regcomp_rx->data->count = n;
1275	}
1276	Copy(s, PL_regcomp_rx->data->what + PL_regcomp_rx->data->count - n, n, U8);
1277	return PL_regcomp_rx->data->count - n;
1278	}
1279
1280	void
1281	Perl_reginitcolors(pTHX)
1282	{
1283	dTHR;
1284	int i = 0;
1285	char *s = PerlEnv_getenv("PERL_RE_COLORS");
1286
1287	if (s) {
1288	PL_colors[0] = s = savepv(s);
1289	while (++i < 6) {
1290	s = strchr(s, '\t');
1291	if (s) {
1292	*s = '\0';
1293	PL_colors[i] = ++s;
1294	}
1295	else
1296	PL_colors[i] = s = "";
1297	}
1298	} else {
1299	while (i < 6)
1300	PL_colors[i++] = "";
1301	}
1302	PL_colorset = 1;
1303	}
1304
1305	/*
1306	- pregcomp - compile a regular expression into internal code
1307	*
1308	* We can't allocate space until we know how big the compiled form will be,
1309	* but we can't compile it (and thus know how big it is) until we've got a
1310	* place to put the code. So we cheat: we compile it twice, once with code
1311	* generation turned off and size counting turned on, and once "for real".
1312	* This also means that we don't allocate space until we are sure that the
1313	* thing really will compile successfully, and we never have to move the
1314	* code and thus invalidate pointers into it. (Note that it has to be in
1315	* one piece because free() must be able to free it all.) [NB: not true in perl]
1316	*
1317	* Beware that the optimization-preparation code in here knows about some
1318	* of the structure of the compiled regexp. [I'll say.]
1319	*/
1320	regexp *
1321	Perl_pregcomp(pTHX_ char exp, char xend, PMOP *pm)
1322	{
1323	dTHR;
1324	register regexp *r;
1325	regnode *scan;
1326	regnode *first;
1327	I32 flags;
1328	I32 minlen = 0;
1329	I32 sawplus = 0;
1330	I32 sawopen = 0;
1331	scan_data_t data;
1332
1333	if (exp == NULL)
1334	FAIL("NULL regexp argument");
1335
1336	if (pm->op_pmdynflags & PMdf_UTF8) {
1337	PL_reg_flags \|= RF_utf8;
1338	}
1339	else
1340	PL_reg_flags = 0;
1341
1342	PL_regprecomp = savepvn(exp, xend - exp);
1343	DEBUG_r(if (!PL_colorset) reginitcolors());
1344	DEBUG_r(PerlIO_printf(Perl_debug_log, "%sCompiling REx%s `%s%*s%s'\n",
1345	PL_colors[4],PL_colors[5],PL_colors[0],
1346	(int)(xend - exp), PL_regprecomp, PL_colors[1]));
1347	PL_regflags = pm->op_pmflags;
1348	PL_regsawback = 0;
1349
1350	PL_regseen = 0;
1351	PL_seen_zerolen = *exp == '^' ? -1 : 0;
1352	PL_seen_evals = 0;
1353	PL_extralen = 0;
1354
1355	/* First pass: determine size, legality. */
1356	PL_regcomp_parse = exp;
1357	PL_regxend = xend;
1358	PL_regnaughty = 0;
1359	PL_regnpar = 1;
1360	PL_regsize = 0L;
1361	PL_regcode = &PL_regdummy;
1362	PL_reg_whilem_seen = 0;
1363	#if 0 /* REGC() is (currently) a NOP at the first pass.
1364	* Clever compilers notice this and complain. --jhi */
1365	REGC((U8)REG_MAGIC, (char*)PL_regcode);
1366	#endif
1367	if (reg(0, &flags) == NULL) {
1368	Safefree(PL_regprecomp);
1369	PL_regprecomp = Nullch;
1370	return(NULL);
1371	}
1372	DEBUG_r(PerlIO_printf(Perl_debug_log, "size %"IVdf" ", (IV)PL_regsize));
1373
1374	/* Small enough for pointer-storage convention?
1375	If extralen==0, this means that we will not need long jumps. */
1376	if (PL_regsize >= 0x10000L && PL_extralen)
1377	PL_regsize += PL_extralen;
1378	else
1379	PL_extralen = 0;
1380	if (PL_reg_whilem_seen > 15)
1381	PL_reg_whilem_seen = 15;
1382
1383	/* Allocate space and initialize. */
1384	Newc(1001, r, sizeof(regexp) + (unsigned)PL_regsize * sizeof(regnode),
1385	char, regexp);
1386	if (r == NULL)
1387	FAIL("regexp out of space");
1388	#ifdef DEBUGGING
1389	/* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
1390	Zero(r, sizeof(regexp) + (unsigned)PL_regsize * sizeof(regnode), char);
1391	#endif
1392	r->refcnt = 1;
1393	r->prelen = xend - exp;
1394	r->precomp = PL_regprecomp;
1395	r->subbeg = NULL;
1396	r->reganch = pm->op_pmflags & PMf_COMPILETIME;
1397	r->nparens = PL_regnpar - 1; /* set early to validate backrefs */
1398
1399	r->substrs = 0; /* Useful during FAIL. */
1400	r->startp = 0; /* Useful during FAIL. */
1401	r->endp = 0; /* Useful during FAIL. */
1402
1403	PL_regcomp_rx = r;
1404
1405	/* Second pass: emit code. */
1406	PL_regcomp_parse = exp;
1407	PL_regxend = xend;
1408	PL_regnaughty = 0;
1409	PL_regnpar = 1;
1410	PL_regcode = r->program;
1411	/* Store the count of eval-groups for security checks: */
1412	PL_regcode->next_off = ((PL_seen_evals > U16_MAX) ? U16_MAX : PL_seen_evals);
1413	REGC((U8)REG_MAGIC, (char*) PL_regcode++);
1414	r->data = 0;
1415	if (reg(0, &flags) == NULL)
1416	return(NULL);
1417
1418	/* Dig out information for optimizations. */
1419	r->reganch = pm->op_pmflags & PMf_COMPILETIME; /* Again? */
1420	pm->op_pmflags = PL_regflags;
1421	if (UTF)
1422	r->reganch \|= ROPT_UTF8;
1423	r->regstclass = NULL;
1424	if (PL_regnaughty >= 10) /* Probably an expensive pattern. */
1425	r->reganch \|= ROPT_NAUGHTY;
1426	scan = r->program + 1; /* First BRANCH. */
1427
1428	/* XXXX To minimize changes to RE engine we always allocate
1429	3-units-long substrs field. */
1430	Newz(1004, r->substrs, 1, struct reg_substr_data);
1431
1432	StructCopy(&zero_scan_data, &data, scan_data_t);
1433	/* XXXX Should not we check for something else? Usually it is OPEN1... */
1434	if (OP(scan) != BRANCH) { /* Only one top-level choice. */
1435	I32 fake;
1436	STRLEN longest_float_length, longest_fixed_length;
1437	struct regnode_charclass_class ch_class;
1438	int stclass_flag;
1439
1440	first = scan;
1441	/* Skip introductions and multiplicators >= 1. */
1442	while ((OP(first) == OPEN && (sawopen = 1)) \|\|
1443	/* An OR of one alternative - should not happen now. */
1444	(OP(first) == BRANCH && OP(regnext(first)) != BRANCH) \|\|
1445	(OP(first) == PLUS) \|\|
1446	(OP(first) == MINMOD) \|\|
1447	/* An {n,m} with n>0 */
1448	(PL_regkind[(U8)OP(first)] == CURLY && ARG1(first) > 0) ) {
1449	if (OP(first) == PLUS)
1450	sawplus = 1;
1451	else
1452	first += regarglen[(U8)OP(first)];
1453	first = NEXTOPER(first);
1454	}
1455
1456	/* Starting-point info. */
1457	again:
1458	if (PL_regkind[(U8)OP(first)] == EXACT) {
1459	if (OP(first) == EXACT); /* Empty, get anchored substr later. */
1460	else if ((OP(first) == EXACTF \|\| OP(first) == EXACTFL)
1461	&& !UTF)
1462	r->regstclass = first;
1463	}
1464	else if (strchr((char*)PL_simple,OP(first)))
1465	r->regstclass = first;
1466	else if (PL_regkind[(U8)OP(first)] == BOUND \|\|
1467	PL_regkind[(U8)OP(first)] == NBOUND)
1468	r->regstclass = first;
1469	else if (PL_regkind[(U8)OP(first)] == BOL) {
1470	r->reganch \|= (OP(first) == MBOL
1471	? ROPT_ANCH_MBOL
1472	: (OP(first) == SBOL
1473	? ROPT_ANCH_SBOL
1474	: ROPT_ANCH_BOL));
1475	first = NEXTOPER(first);
1476	goto again;
1477	}
1478	else if (OP(first) == GPOS) {
1479	r->reganch \|= ROPT_ANCH_GPOS;
1480	first = NEXTOPER(first);
1481	goto again;
1482	}
1483	else if ((OP(first) == STAR &&
1484	PL_regkind[(U8)OP(NEXTOPER(first))] == REG_ANY) &&
1485	!(r->reganch & ROPT_ANCH) )
1486	{
1487	/* turn .* into ^.* with an implied $=1 /
1488	int type = OP(NEXTOPER(first));
1489
1490	if (type == REG_ANY \|\| type == ANYUTF8)
1491	type = ROPT_ANCH_MBOL;
1492	else
1493	type = ROPT_ANCH_SBOL;
1494
1495	r->reganch \|= type \| ROPT_IMPLICIT;
1496	first = NEXTOPER(first);
1497	goto again;
1498	}
1499	if (sawplus && (!sawopen \|\| !PL_regsawback)
1500	&& !(PL_regseen & REG_SEEN_EVAL)) /* May examine pos and $& */
1501	/* x+ must match at the 1st pos of run of x's */
1502	r->reganch \|= ROPT_SKIP;
1503
1504	/* Scan is after the zeroth branch, first is atomic matcher. */
1505	DEBUG_r(PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
1506	(IV)(first - scan + 1)));
1507	/*
1508	* If there's something expensive in the r.e., find the
1509	* longest literal string that must appear and make it the
1510	* regmust. Resolve ties in favor of later strings, since
1511	* the regstart check works with the beginning of the r.e.
1512	* and avoiding duplication strengthens checking. Not a
1513	* strong reason, but sufficient in the absence of others.
1514	* [Now we resolve ties in favor of the earlier string if
1515	* it happens that c_offset_min has been invalidated, since the
1516	* earlier string may buy us something the later one won't.]
1517	*/
1518	minlen = 0;
1519
1520	data.longest_fixed = newSVpvn("",0);
1521	data.longest_float = newSVpvn("",0);
1522	data.last_found = newSVpvn("",0);
1523	data.longest = &(data.longest_fixed);
1524	first = scan;
1525	if (!r->regstclass) {
1526	cl_init(&ch_class);
1527	data.start_class = &ch_class;
1528	stclass_flag = SCF_DO_STCLASS_AND;
1529	} else /* XXXX Check for BOUND? */
1530	stclass_flag = 0;
1531
1532	minlen = study_chunk(&first, &fake, scan + PL_regsize, /* Up to end */
1533	&data, SCF_DO_SUBSTR \| stclass_flag);
1534	if ( PL_regnpar == 1 && data.longest == &(data.longest_fixed)
1535	&& data.last_start_min == 0 && data.last_end > 0
1536	&& !PL_seen_zerolen
1537	&& (!(PL_regseen & REG_SEEN_GPOS) \|\| (r->reganch & ROPT_ANCH_GPOS)))
1538	r->reganch \|= ROPT_CHECK_ALL;
1539	scan_commit(&data);
1540	SvREFCNT_dec(data.last_found);
1541
1542	longest_float_length = CHR_SVLEN(data.longest_float);
1543	if (longest_float_length
1544	\|\| (data.flags & SF_FL_BEFORE_EOL
1545	&& (!(data.flags & SF_FL_BEFORE_MEOL)
1546	\|\| (PL_regflags & PMf_MULTILINE)))) {
1547	int t;
1548
1549	if (SvCUR(data.longest_fixed) /* ok to leave SvCUR */
1550	&& data.offset_fixed == data.offset_float_min
1551	&& SvCUR(data.longest_fixed) == SvCUR(data.longest_float))
1552	goto remove_float; /* As in (a)+. */
1553
1554	r->float_substr = data.longest_float;
1555	r->float_min_offset = data.offset_float_min;
1556	r->float_max_offset = data.offset_float_max;
1557	t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
1558	&& (!(data.flags & SF_FL_BEFORE_MEOL)
1559	\|\| (PL_regflags & PMf_MULTILINE)));
1560	fbm_compile(r->float_substr, t ? FBMcf_TAIL : 0);
1561	}
1562	else {
1563	remove_float:
1564	r->float_substr = Nullsv;
1565	SvREFCNT_dec(data.longest_float);
1566	longest_float_length = 0;
1567	}
1568
1569	longest_fixed_length = CHR_SVLEN(data.longest_fixed);
1570	if (longest_fixed_length
1571	\|\| (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
1572	&& (!(data.flags & SF_FIX_BEFORE_MEOL)
1573	\|\| (PL_regflags & PMf_MULTILINE)))) {
1574	int t;
1575
1576	r->anchored_substr = data.longest_fixed;
1577	r->anchored_offset = data.offset_fixed;
1578	t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
1579	&& (!(data.flags & SF_FIX_BEFORE_MEOL)
1580	\|\| (PL_regflags & PMf_MULTILINE)));
1581	fbm_compile(r->anchored_substr, t ? FBMcf_TAIL : 0);
1582	}
1583	else {
1584	r->anchored_substr = Nullsv;
1585	SvREFCNT_dec(data.longest_fixed);
1586	longest_fixed_length = 0;
1587	}
1588	if (r->regstclass
1589	&& (OP(r->regstclass) == REG_ANY \|\| OP(r->regstclass) == ANYUTF8
1590	\|\| OP(r->regstclass) == SANYUTF8 \|\| OP(r->regstclass) == SANY))
1591	r->regstclass = NULL;
1592	if ((!r->anchored_substr \|\| r->anchored_offset) && stclass_flag
1593	&& !(data.start_class->flags & ANYOF_EOS)
1594	&& !cl_is_anything(data.start_class)) {
1595	SV *sv;
1596	I32 n = add_data(1, "f");
1597
1598	New(1006, PL_regcomp_rx->data->data[n], 1,
1599	struct regnode_charclass_class);
1600	StructCopy(data.start_class,
1601	(struct regnode_charclass_class*)PL_regcomp_rx->data->data[n],
1602	struct regnode_charclass_class);
1603	r->regstclass = (regnode*)PL_regcomp_rx->data->data[n];
1604	r->reganch &= ~ROPT_SKIP; /* Used in find_byclass(). */
1605	DEBUG_r((sv = sv_newmortal(),
1606	regprop(sv, (regnode*)data.start_class),
1607	PerlIO_printf(Perl_debug_log, "synthetic stclass `%s'.\n",
1608	SvPVX(sv))));
1609	}
1610
1611	/* A temporary algorithm prefers floated substr to fixed one to dig more info. */
1612	if (longest_fixed_length > longest_float_length) {
1613	r->check_substr = r->anchored_substr;
1614	r->check_offset_min = r->check_offset_max = r->anchored_offset;
1615	if (r->reganch & ROPT_ANCH_SINGLE)
1616	r->reganch \|= ROPT_NOSCAN;
1617	}
1618	else {
1619	r->check_substr = r->float_substr;
1620	r->check_offset_min = data.offset_float_min;
1621	r->check_offset_max = data.offset_float_max;
1622	}
1623	/* XXXX Currently intuiting is not compatible with ANCH_GPOS.
1624	This should be changed ASAP! */
1625	if (r->check_substr && !(r->reganch & ROPT_ANCH_GPOS)) {
1626	r->reganch \|= RE_USE_INTUIT;
1627	if (SvTAIL(r->check_substr))
1628	r->reganch \|= RE_INTUIT_TAIL;
1629	}
1630	}
1631	else {
1632	/* Several toplevels. Best we can is to set minlen. */
1633	I32 fake;
1634	struct regnode_charclass_class ch_class;
1635
1636	DEBUG_r(PerlIO_printf(Perl_debug_log, "\n"));
1637	scan = r->program + 1;
1638	cl_init(&ch_class);
1639	data.start_class = &ch_class;
1640	minlen = study_chunk(&scan, &fake, scan + PL_regsize, &data, SCF_DO_STCLASS_AND);
1641	r->check_substr = r->anchored_substr = r->float_substr = Nullsv;
1642	if (!(data.start_class->flags & ANYOF_EOS)
1643	&& !cl_is_anything(data.start_class)) {
1644	SV *sv;
1645	I32 n = add_data(1, "f");
1646
1647	New(1006, PL_regcomp_rx->data->data[n], 1,
1648	struct regnode_charclass_class);
1649	StructCopy(data.start_class,
1650	(struct regnode_charclass_class*)PL_regcomp_rx->data->data[n],
1651	struct regnode_charclass_class);
1652	r->regstclass = (regnode*)PL_regcomp_rx->data->data[n];
1653	r->reganch &= ~ROPT_SKIP; /* Used in find_byclass(). */
1654	DEBUG_r((sv = sv_newmortal(),
1655	regprop(sv, (regnode*)data.start_class),
1656	PerlIO_printf(Perl_debug_log, "synthetic stclass `%s'.\n",
1657	SvPVX(sv))));
1658	}
1659	}
1660
1661	r->minlen = minlen;
1662	if (PL_regseen & REG_SEEN_GPOS)
1663	r->reganch \|= ROPT_GPOS_SEEN;
1664	if (PL_regseen & REG_SEEN_LOOKBEHIND)
1665	r->reganch \|= ROPT_LOOKBEHIND_SEEN;
1666	if (PL_regseen & REG_SEEN_EVAL)
1667	r->reganch \|= ROPT_EVAL_SEEN;
1668	Newz(1002, r->startp, PL_regnpar, I32);
1669	Newz(1002, r->endp, PL_regnpar, I32);
1670	DEBUG_r(regdump(r));
1671	return(r);
1672	}
1673
1674	/*
1675	- reg - regular expression, i.e. main body or parenthesized thing
1676	*
1677	* Caller must absorb opening parenthesis.
1678	*
1679	* Combining parenthesis handling with the base level of regular expression
1680	* is a trifle forced, but the need to tie the tails of the branches to what
1681	* follows makes it hard to avoid.
1682	*/
1683	STATIC regnode *
1684	S_reg(pTHX_ I32 paren, I32 *flagp)
1685	/* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
1686	{
1687	dTHR;
1688	register regnode ret; / Will be the head of the group. */
1689	register regnode *br;
1690	register regnode *lastbr;
1691	register regnode *ender = 0;
1692	register I32 parno = 0;
1693	I32 flags, oregflags = PL_regflags, have_branch = 0, open = 0;
1694	char c;
1695
1696	flagp = 0; / Tentatively. */
1697
1698	/* Make an OPEN node, if parenthesized. */
1699	if (paren) {
1700	if (*PL_regcomp_parse == '?') {
1701	U16 posflags = 0, negflags = 0;
1702	U16 *flagsp = &posflags;
1703	int logical = 0;
1704
1705	PL_regcomp_parse++;
1706	paren = *PL_regcomp_parse++;
1707	ret = NULL; /* For look-ahead/behind. */
1708	switch (paren) {
1709	case '<':
1710	PL_regseen \|= REG_SEEN_LOOKBEHIND;
1711	if (*PL_regcomp_parse == '!')
1712	paren = ',';
1713	if (PL_regcomp_parse != '=' && PL_regcomp_parse != '!')
1714	goto unknown;
1715	PL_regcomp_parse++;
1716	case '=':
1717	case '!':
1718	PL_seen_zerolen++;
1719	case ':':
1720	case '>':
1721	break;
1722	case '$':
1723	case '@':
1724	FAIL2("Sequence (?%c...) not implemented", (int)paren);
1725	break;
1726	case '#':
1727	while (PL_regcomp_parse && PL_regcomp_parse != ')')
1728	PL_regcomp_parse++;
1729	if (*PL_regcomp_parse != ')')
1730	FAIL("Sequence (?#... not terminated");
1731	nextchar();
1732	*flagp = TRYAGAIN;
1733	return NULL;
1734	case 'p':
1735	if (SIZE_ONLY)
1736	Perl_warner(aTHX_ WARN_REGEXP,
1737	"(?p{}) is deprecated - use (??{})");
1738	/* FALL THROUGH*/
1739	case '?':
1740	logical = 1;
1741	paren = *PL_regcomp_parse++;
1742	/* FALL THROUGH */
1743	case '{':
1744	{
1745	dTHR;
1746	I32 count = 1, n = 0;
1747	char c;
1748	char *s = PL_regcomp_parse;
1749	SV *sv;
1750	OP_4tree sop, rop;
1751
1752	PL_seen_zerolen++;
1753	PL_regseen \|= REG_SEEN_EVAL;
1754	while (count && (c = *PL_regcomp_parse)) {
1755	if (c == '\\' && PL_regcomp_parse[1])
1756	PL_regcomp_parse++;
1757	else if (c == '{')
1758	count++;
1759	else if (c == '}')
1760	count--;
1761	PL_regcomp_parse++;
1762	}
1763	if (*PL_regcomp_parse != ')')
1764	FAIL("Sequence (?{...}) not terminated or not {}-balanced");
1765	if (!SIZE_ONLY) {
1766	AV *av;
1767
1768	if (PL_regcomp_parse - 1 - s)
1769	sv = newSVpvn(s, PL_regcomp_parse - 1 - s);
1770	else
1771	sv = newSVpvn("", 0);
1772
1773	rop = sv_compile_2op(sv, &sop, "re", &av);
1774
1775	n = add_data(3, "nop");
1776	PL_regcomp_rx->data->data[n] = (void*)rop;
1777	PL_regcomp_rx->data->data[n+1] = (void*)sop;
1778	PL_regcomp_rx->data->data[n+2] = (void*)av;
1779	SvREFCNT_dec(sv);
1780	}
1781	else { /* First pass */
1782	if (PL_reginterp_cnt < ++PL_seen_evals
1783	&& PL_curcop != &PL_compiling)
1784	/* No compiled RE interpolated, has runtime
1785	components ===> unsafe. */
1786	FAIL("Eval-group not allowed at runtime, use re 'eval'");
1787	if (PL_tainted)
1788	FAIL("Eval-group in insecure regular expression");
1789	}
1790
1791	nextchar();
1792	if (logical) {
1793	ret = reg_node(LOGICAL);
1794	if (!SIZE_ONLY)
1795	ret->flags = 2;
1796	regtail(ret, reganode(EVAL, n));
1797	return ret;
1798	}
1799	return reganode(EVAL, n);
1800	}
1801	case '(':
1802	{
1803	if (PL_regcomp_parse[0] == '?') {
1804	if (PL_regcomp_parse[1] == '=' \|\| PL_regcomp_parse[1] == '!'
1805	\|\| PL_regcomp_parse[1] == '<'
1806	\|\| PL_regcomp_parse[1] == '{') { /* Lookahead or eval. */
1807	I32 flag;
1808
1809	ret = reg_node(LOGICAL);
1810	if (!SIZE_ONLY)
1811	ret->flags = 1;
1812	regtail(ret, reg(1, &flag));
1813	goto insert_if;
1814	}
1815	}
1816	else if (PL_regcomp_parse[0] >= '1' && PL_regcomp_parse[0] <= '9' ) {
1817	parno = atoi(PL_regcomp_parse++);
1818
1819	while (isDIGIT(*PL_regcomp_parse))
1820	PL_regcomp_parse++;
1821	ret = reganode(GROUPP, parno);
1822	if ((c = *nextchar()) != ')')
1823	FAIL2("Switch (?(number%c not recognized", c);
1824	insert_if:
1825	regtail(ret, reganode(IFTHEN, 0));
1826	br = regbranch(&flags, 1);
1827	if (br == NULL)
1828	br = reganode(LONGJMP, 0);
1829	else
1830	regtail(br, reganode(LONGJMP, 0));
1831	c = *nextchar();
1832	if (flags&HASWIDTH)
1833	*flagp \|= HASWIDTH;
1834	if (c == '\|') {
1835	lastbr = reganode(IFTHEN, 0); /* Fake one for optimizer. */
1836	regbranch(&flags, 1);
1837	regtail(ret, lastbr);
1838	if (flags&HASWIDTH)
1839	*flagp \|= HASWIDTH;
1840	c = *nextchar();
1841	}
1842	else
1843	lastbr = NULL;
1844	if (c != ')')
1845	FAIL("Switch (?(condition)... contains too many branches");
1846	ender = reg_node(TAIL);
1847	regtail(br, ender);
1848	if (lastbr) {
1849	regtail(lastbr, ender);
1850	regtail(NEXTOPER(NEXTOPER(lastbr)), ender);
1851	}
1852	else
1853	regtail(ret, ender);
1854	return ret;
1855	}
1856	else {
1857	FAIL2("Unknown condition for (?(%.2s", PL_regcomp_parse);
1858	}
1859	}
1860	case 0:
1861	FAIL("Sequence (? incomplete");
1862	break;
1863	default:
1864	--PL_regcomp_parse;
1865	parse_flags:
1866	while (PL_regcomp_parse && strchr("iogcmsx", PL_regcomp_parse)) {
1867	if (*PL_regcomp_parse != 'o')
1868	pmflag(flagsp, *PL_regcomp_parse);
1869	++PL_regcomp_parse;
1870	}
1871	if (*PL_regcomp_parse == '-') {
1872	flagsp = &negflags;
1873	++PL_regcomp_parse;
1874	goto parse_flags;
1875	}
1876	PL_regflags \|= posflags;
1877	PL_regflags &= ~negflags;
1878	if (*PL_regcomp_parse == ':') {
1879	PL_regcomp_parse++;
1880	paren = ':';
1881	break;
1882	}
1883	unknown:
1884	if (*PL_regcomp_parse != ')')
1885	FAIL2("Sequence (?%c...) not recognized", *PL_regcomp_parse);
1886	nextchar();
1887	*flagp = TRYAGAIN;
1888	return NULL;
1889	}
1890	}
1891	else {
1892	parno = PL_regnpar;
1893	PL_regnpar++;
1894	ret = reganode(OPEN, parno);
1895	open = 1;
1896	}
1897	}
1898	else
1899	ret = NULL;
1900
1901	/* Pick up the branches, linking them together. */
1902	br = regbranch(&flags, 1);
1903	if (br == NULL)
1904	return(NULL);
1905	if (*PL_regcomp_parse == '\|') {
1906	if (!SIZE_ONLY && PL_extralen) {
1907	reginsert(BRANCHJ, br);
1908	}
1909	else
1910	reginsert(BRANCH, br);
1911	have_branch = 1;
1912	if (SIZE_ONLY)
1913	PL_extralen += 1; /* For BRANCHJ-BRANCH. */
1914	}
1915	else if (paren == ':') {
1916	*flagp \|= flags&SIMPLE;
1917	}
1918	if (open) { /* Starts with OPEN. */
1919	regtail(ret, br); /* OPEN -> first. */
1920	}
1921	else if (paren != '?') /* Not Conditional */
1922	ret = br;
1923	if (flags&HASWIDTH)
1924	*flagp \|= HASWIDTH;
1925	*flagp \|= flags&SPSTART;
1926	lastbr = br;
1927	while (*PL_regcomp_parse == '\|') {
1928	if (!SIZE_ONLY && PL_extralen) {
1929	ender = reganode(LONGJMP,0);
1930	regtail(NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
1931	}
1932	if (SIZE_ONLY)
1933	PL_extralen += 2; /* Account for LONGJMP. */
1934	nextchar();
1935	br = regbranch(&flags, 0);
1936	if (br == NULL)
1937	return(NULL);
1938	regtail(lastbr, br); /* BRANCH -> BRANCH. */
1939	lastbr = br;
1940	if (flags&HASWIDTH)
1941	*flagp \|= HASWIDTH;
1942	*flagp \|= flags&SPSTART;
1943	}
1944
1945	if (have_branch \|\| paren != ':') {
1946	/* Make a closing node, and hook it on the end. */
1947	switch (paren) {
1948	case ':':
1949	ender = reg_node(TAIL);
1950	break;
1951	case 1:
1952	ender = reganode(CLOSE, parno);
1953	break;
1954	case '<':
1955	case ',':
1956	case '=':
1957	case '!':
1958	*flagp &= ~HASWIDTH;
1959	/* FALL THROUGH */
1960	case '>':
1961	ender = reg_node(SUCCEED);
1962	break;
1963	case 0:
1964	ender = reg_node(END);
1965	break;
1966	}
1967	regtail(lastbr, ender);
1968
1969	if (have_branch) {
1970	/* Hook the tails of the branches to the closing node. */
1971	for (br = ret; br != NULL; br = regnext(br)) {
1972	regoptail(br, ender);
1973	}
1974	}
1975	}
1976
1977	{
1978	char *p;
1979	static char parens[] = "=!<,>";
1980
1981	if (paren && (p = strchr(parens, paren))) {
1982	int node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
1983	int flag = (p - parens) > 1;
1984
1985	if (paren == '>')
1986	node = SUSPEND, flag = 0;
1987	reginsert(node,ret);
1988	ret->flags = flag;
1989	regtail(ret, reg_node(TAIL));
1990	}
1991	}
1992
1993	/* Check for proper termination. */
1994	if (paren) {
1995	PL_regflags = oregflags;
1996	if (PL_regcomp_parse >= PL_regxend \|\| *nextchar() != ')') {
1997	FAIL("unmatched () in regexp");
1998	}
1999	}
2000	else if (!paren && PL_regcomp_parse < PL_regxend) {
2001	if (*PL_regcomp_parse == ')') {
2002	FAIL("unmatched () in regexp");
2003	}
2004	else
2005	FAIL("junk on end of regexp"); /* "Can't happen". */
2006	/* NOTREACHED */
2007	}
2008
2009	return(ret);
2010	}
2011
2012	/*
2013	- regbranch - one alternative of an \| operator
2014	*
2015	* Implements the concatenation operator.
2016	*/
2017	STATIC regnode *
2018	S_regbranch(pTHX_ I32 *flagp, I32 first)
2019	{
2020	dTHR;
2021	register regnode *ret;
2022	register regnode *chain = NULL;
2023	register regnode *latest;
2024	I32 flags = 0, c = 0;
2025
2026	if (first)
2027	ret = NULL;
2028	else {
2029	if (!SIZE_ONLY && PL_extralen)
2030	ret = reganode(BRANCHJ,0);
2031	else
2032	ret = reg_node(BRANCH);
2033	}
2034
2035	if (!first && SIZE_ONLY)
2036	PL_extralen += 1; /* BRANCHJ */
2037
2038	flagp = WORST; / Tentatively. */
2039
2040	PL_regcomp_parse--;
2041	nextchar();
2042	while (PL_regcomp_parse < PL_regxend && PL_regcomp_parse != '\|' && PL_regcomp_parse != ')') {
2043	flags &= ~TRYAGAIN;
2044	latest = regpiece(&flags);
2045	if (latest == NULL) {
2046	if (flags & TRYAGAIN)
2047	continue;
2048	return(NULL);
2049	}
2050	else if (ret == NULL)
2051	ret = latest;
2052	*flagp \|= flags&HASWIDTH;
2053	if (chain == NULL) /* First piece. */
2054	*flagp \|= flags&SPSTART;
2055	else {
2056	PL_regnaughty++;
2057	regtail(chain, latest);
2058	}
2059	chain = latest;
2060	c++;
2061	}
2062	if (chain == NULL) { /* Loop ran zero times. */
2063	chain = reg_node(NOTHING);
2064	if (ret == NULL)
2065	ret = chain;
2066	}
2067	if (c == 1) {
2068	*flagp \|= flags&SIMPLE;
2069	}
2070
2071	return(ret);
2072	}
2073
2074	/*
2075	- regpiece - something followed by possible [*+?]
2076	*
2077	* Note that the branching code sequences used for ? and the general cases
2078	* of * and + are somewhat optimized: they use the same NOTHING node as
2079	* both the endmarker for their branch list and the body of the last branch.
2080	* It might seem that this node could be dispensed with entirely, but the
2081	* endmarker role is not redundant.
2082	*/
2083	STATIC regnode *
2084	S_regpiece(pTHX_ I32 *flagp)
2085	{
2086	dTHR;
2087	register regnode *ret;
2088	register char op;
2089	register char *next;
2090	I32 flags;
2091	char *origparse = PL_regcomp_parse;
2092	char *maxpos;
2093	I32 min;
2094	I32 max = REG_INFTY;
2095
2096	ret = regatom(&flags);
2097	if (ret == NULL) {
2098	if (flags & TRYAGAIN)
2099	*flagp \|= TRYAGAIN;
2100	return(NULL);
2101	}
2102
2103	op = *PL_regcomp_parse;
2104
2105	if (op == '{' && regcurly(PL_regcomp_parse)) {
2106	next = PL_regcomp_parse + 1;
2107	maxpos = Nullch;
2108	while (isDIGIT(next) \|\| next == ',') {
2109	if (*next == ',') {
2110	if (maxpos)
2111	break;
2112	else
2113	maxpos = next;
2114	}
2115	next++;
2116	}
2117	if (next == '}') { / got one */
2118	if (!maxpos)
2119	maxpos = next;
2120	PL_regcomp_parse++;
2121	min = atoi(PL_regcomp_parse);
2122	if (*maxpos == ',')
2123	maxpos++;
2124	else
2125	maxpos = PL_regcomp_parse;
2126	max = atoi(maxpos);
2127	if (!max && *maxpos != '0')
2128	max = REG_INFTY; /* meaning "infinity" */
2129	else if (max >= REG_INFTY)
2130	FAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
2131	PL_regcomp_parse = next;
2132	nextchar();
2133
2134	do_curly:
2135	if ((flags&SIMPLE)) {
2136	PL_regnaughty += 2 + PL_regnaughty / 2;
2137	reginsert(CURLY, ret);
2138	}
2139	else {
2140	regnode *w = reg_node(WHILEM);
2141
2142	w->flags = 0;
2143	regtail(ret, w);
2144	if (!SIZE_ONLY && PL_extralen) {
2145	reginsert(LONGJMP,ret);
2146	reginsert(NOTHING,ret);
2147	NEXT_OFF(ret) = 3; /* Go over LONGJMP. */
2148	}
2149	reginsert(CURLYX,ret);
2150	if (!SIZE_ONLY && PL_extralen)
2151	NEXT_OFF(ret) = 3; /* Go over NOTHING to LONGJMP. */
2152	regtail(ret, reg_node(NOTHING));
2153	if (SIZE_ONLY)
2154	PL_reg_whilem_seen++, PL_extralen += 3;
2155	PL_regnaughty += 4 + PL_regnaughty; /* compound interest */
2156	}
2157	ret->flags = 0;
2158
2159	if (min > 0)
2160	*flagp = WORST;
2161	if (max > 0)
2162	*flagp \|= HASWIDTH;
2163	if (max && max < min)
2164	FAIL("Can't do {n,m} with n > m");
2165	if (!SIZE_ONLY) {
2166	ARG1_SET(ret, min);
2167	ARG2_SET(ret, max);
2168	}
2169
2170	goto nest_check;
2171	}
2172	}
2173
2174	if (!ISMULT1(op)) {
2175	*flagp = flags;
2176	return(ret);
2177	}
2178
2179	#if 0 /* Now runtime fix should be reliable. */
2180	if (!(flags&HASWIDTH) && op != '?')
2181	FAIL("regexp *+ operand could be empty");
2182	#endif
2183
2184	nextchar();
2185
2186	*flagp = (op != '+') ? (WORST\|SPSTART\|HASWIDTH) : (WORST\|HASWIDTH);
2187
2188	if (op == '*' && (flags&SIMPLE)) {
2189	reginsert(STAR, ret);
2190	ret->flags = 0;
2191	PL_regnaughty += 4;
2192	}
2193	else if (op == '*') {
2194	min = 0;
2195	goto do_curly;
2196	}
2197	else if (op == '+' && (flags&SIMPLE)) {
2198	reginsert(PLUS, ret);
2199	ret->flags = 0;
2200	PL_regnaughty += 3;
2201	}
2202	else if (op == '+') {
2203	min = 1;
2204	goto do_curly;
2205	}
2206	else if (op == '?') {
2207	min = 0; max = 1;
2208	goto do_curly;
2209	}
2210	nest_check:
2211	if (ckWARN(WARN_REGEXP) && !SIZE_ONLY && !(flags&HASWIDTH) && max > REG_INFTY/3) {
2212	Perl_warner(aTHX_ WARN_REGEXP, "%.*s matches null string many times",
2213	PL_regcomp_parse - origparse, origparse);
2214	}
2215
2216	if (*PL_regcomp_parse == '?') {
2217	nextchar();
2218	reginsert(MINMOD, ret);
2219	regtail(ret, ret + NODE_STEP_REGNODE);
2220	}
2221	if (ISMULT2(PL_regcomp_parse))
2222	FAIL("nested *?+ in regexp");
2223
2224	return(ret);
2225	}
2226
2227	/*
2228	- regatom - the lowest level
2229	*
2230	* Optimization: gobbles an entire sequence of ordinary characters so that
2231	* it can turn them into a single node, which is smaller to store and
2232	* faster to run. Backslashed characters are exceptions, each becoming a
2233	* separate node; the code is simpler that way and it's not worth fixing.
2234	*
2235	* [Yes, it is worth fixing, some scripts can run twice the speed.]
2236	*/
2237	STATIC regnode *
2238	S_regatom(pTHX_ I32 *flagp)
2239	{
2240	dTHR;
2241	register regnode *ret = 0;
2242	I32 flags;
2243
2244	flagp = WORST; / Tentatively. */
2245
2246	tryagain:
2247	switch (*PL_regcomp_parse) {
2248	case '^':
2249	PL_seen_zerolen++;
2250	nextchar();
2251	if (PL_regflags & PMf_MULTILINE)
2252	ret = reg_node(MBOL);
2253	else if (PL_regflags & PMf_SINGLELINE)
2254	ret = reg_node(SBOL);
2255	else
2256	ret = reg_node(BOL);
2257	break;
2258	case '$':
2259	if (PL_regcomp_parse[1])
2260	PL_seen_zerolen++;
2261	nextchar();
2262	if (PL_regflags & PMf_MULTILINE)
2263	ret = reg_node(MEOL);
2264	else if (PL_regflags & PMf_SINGLELINE)
2265	ret = reg_node(SEOL);
2266	else
2267	ret = reg_node(EOL);
2268	break;
2269	case '.':
2270	nextchar();
2271	if (UTF) {
2272	if (PL_regflags & PMf_SINGLELINE)
2273	ret = reg_node(SANYUTF8);
2274	else
2275	ret = reg_node(ANYUTF8);
2276	*flagp \|= HASWIDTH;
2277	}
2278	else {
2279	if (PL_regflags & PMf_SINGLELINE)
2280	ret = reg_node(SANY);
2281	else
2282	ret = reg_node(REG_ANY);
2283	*flagp \|= HASWIDTH\|SIMPLE;
2284	}
2285	PL_regnaughty++;
2286	break;
2287	case '[':
2288	PL_regcomp_parse++;
2289	ret = (UTF ? regclassutf8() : regclass());
2290	if (*PL_regcomp_parse != ']')
2291	FAIL("unmatched [] in regexp");
2292	nextchar();
2293	*flagp \|= HASWIDTH\|SIMPLE;
2294	break;
2295	case '(':
2296	nextchar();
2297	ret = reg(1, &flags);
2298	if (ret == NULL) {
2299	if (flags & TRYAGAIN)
2300	goto tryagain;
2301	return(NULL);
2302	}
2303	*flagp \|= flags&(HASWIDTH\|SPSTART\|SIMPLE);
2304	break;
2305	case '\|':
2306	case ')':
2307	if (flags & TRYAGAIN) {
2308	*flagp \|= TRYAGAIN;
2309	return NULL;
2310	}
2311	FAIL2("internal urp in regexp at /%s/", PL_regcomp_parse);
2312	/* Supposed to be caught earlier. */
2313	break;
2314	case '{':
2315	if (!regcurly(PL_regcomp_parse)) {
2316	PL_regcomp_parse++;
2317	goto defchar;
2318	}
2319	/* FALL THROUGH */
2320	case '?':
2321	case '+':
2322	case '*':
2323	FAIL("?+*{} follows nothing in regexp");
2324	break;
2325	case '\\':
2326	switch (*++PL_regcomp_parse) {
2327	case 'A':
2328	PL_seen_zerolen++;
2329	ret = reg_node(SBOL);
2330	*flagp \|= SIMPLE;
2331	nextchar();
2332	break;
2333	case 'G':
2334	ret = reg_node(GPOS);
2335	PL_regseen \|= REG_SEEN_GPOS;
2336	*flagp \|= SIMPLE;
2337	nextchar();
2338	break;
2339	case 'Z':
2340	ret = reg_node(SEOL);
2341	*flagp \|= SIMPLE;
2342	nextchar();
2343	break;
2344	case 'z':
2345	ret = reg_node(EOS);
2346	*flagp \|= SIMPLE;
2347	PL_seen_zerolen++; /* Do not optimize RE away */
2348	nextchar();
2349	break;
2350	case 'C':
2351	ret = reg_node(SANY);
2352	*flagp \|= HASWIDTH\|SIMPLE;
2353	nextchar();
2354	break;
2355	case 'X':
2356	ret = reg_node(CLUMP);
2357	*flagp \|= HASWIDTH;
2358	nextchar();
2359	if (UTF && !PL_utf8_mark)
2360	is_utf8_mark((U8)"~"); / preload table */
2361	break;
2362	case 'w':
2363	ret = reg_node(
2364	UTF
2365	? (LOC ? ALNUMLUTF8 : ALNUMUTF8)
2366	: (LOC ? ALNUML : ALNUM));
2367	*flagp \|= HASWIDTH\|SIMPLE;
2368	nextchar();
2369	if (UTF && !PL_utf8_alnum)
2370	is_utf8_alnum((U8)"a"); / preload table */
2371	break;
2372	case 'W':
2373	ret = reg_node(
2374	UTF
2375	? (LOC ? NALNUMLUTF8 : NALNUMUTF8)
2376	: (LOC ? NALNUML : NALNUM));
2377	*flagp \|= HASWIDTH\|SIMPLE;
2378	nextchar();
2379	if (UTF && !PL_utf8_alnum)
2380	is_utf8_alnum((U8)"a"); / preload table */
2381	break;
2382	case 'b':
2383	PL_seen_zerolen++;
2384	PL_regseen \|= REG_SEEN_LOOKBEHIND;
2385	ret = reg_node(
2386	UTF
2387	? (LOC ? BOUNDLUTF8 : BOUNDUTF8)
2388	: (LOC ? BOUNDL : BOUND));
2389	*flagp \|= SIMPLE;
2390	nextchar();
2391	if (UTF && !PL_utf8_alnum)
2392	is_utf8_alnum((U8)"a"); / preload table */
2393	break;
2394	case 'B':
2395	PL_seen_zerolen++;
2396	PL_regseen \|= REG_SEEN_LOOKBEHIND;
2397	ret = reg_node(
2398	UTF
2399	? (LOC ? NBOUNDLUTF8 : NBOUNDUTF8)
2400	: (LOC ? NBOUNDL : NBOUND));
2401	*flagp \|= SIMPLE;
2402	nextchar();
2403	if (UTF && !PL_utf8_alnum)
2404	is_utf8_alnum((U8)"a"); / preload table */
2405	break;
2406	case 's':
2407	ret = reg_node(
2408	UTF
2409	? (LOC ? SPACELUTF8 : SPACEUTF8)
2410	: (LOC ? SPACEL : SPACE));
2411	*flagp \|= HASWIDTH\|SIMPLE;
2412	nextchar();
2413	if (UTF && !PL_utf8_space)
2414	is_utf8_space((U8)" "); / preload table */
2415	break;
2416	case 'S':
2417	ret = reg_node(
2418	UTF
2419	? (LOC ? NSPACELUTF8 : NSPACEUTF8)
2420	: (LOC ? NSPACEL : NSPACE));
2421	*flagp \|= HASWIDTH\|SIMPLE;
2422	nextchar();
2423	if (UTF && !PL_utf8_space)
2424	is_utf8_space((U8)" "); / preload table */
2425	break;
2426	case 'd':
2427	ret = reg_node(UTF ? DIGITUTF8 : DIGIT);
2428	*flagp \|= HASWIDTH\|SIMPLE;
2429	nextchar();
2430	if (UTF && !PL_utf8_digit)
2431	is_utf8_digit((U8)"1"); / preload table */
2432	break;
2433	case 'D':
2434	ret = reg_node(UTF ? NDIGITUTF8 : NDIGIT);
2435	*flagp \|= HASWIDTH\|SIMPLE;
2436	nextchar();
2437	if (UTF && !PL_utf8_digit)
2438	is_utf8_digit((U8)"1"); / preload table */
2439	break;
2440	case 'p':
2441	case 'P':
2442	{ /* a lovely hack--pretend we saw [\pX] instead */
2443	char* oldregxend = PL_regxend;
2444
2445	if (PL_regcomp_parse[1] == '{') {
2446	PL_regxend = strchr(PL_regcomp_parse, '}');
2447	if (!PL_regxend)
2448	FAIL("Missing right brace on \\p{}");
2449	PL_regxend++;
2450	}
2451	else
2452	PL_regxend = PL_regcomp_parse + 2;
2453	PL_regcomp_parse--;
2454
2455	ret = regclassutf8();
2456
2457	PL_regxend = oldregxend;
2458	PL_regcomp_parse--;
2459	nextchar();
2460	*flagp \|= HASWIDTH\|SIMPLE;
2461	}
2462	break;
2463	case 'n':
2464	case 'r':
2465	case 't':
2466	case 'f':
2467	case 'e':
2468	case 'a':
2469	case 'x':
2470	case 'c':
2471	case '0':
2472	goto defchar;
2473	case '1': case '2': case '3': case '4':
2474	case '5': case '6': case '7': case '8': case '9':
2475	{
2476	I32 num = atoi(PL_regcomp_parse);
2477
2478	if (num > 9 && num >= PL_regnpar)
2479	goto defchar;
2480	else {
2481	if (!SIZE_ONLY && num > PL_regcomp_rx->nparens)
2482	FAIL("reference to nonexistent group");
2483	PL_regsawback = 1;
2484	ret = reganode(FOLD
2485	? (LOC ? REFFL : REFF)
2486	: REF, num);
2487	*flagp \|= HASWIDTH;
2488	while (isDIGIT(*PL_regcomp_parse))
2489	PL_regcomp_parse++;
2490	PL_regcomp_parse--;
2491	nextchar();
2492	}
2493	}
2494	break;
2495	case '\0':
2496	if (PL_regcomp_parse >= PL_regxend)
2497	FAIL("trailing \\ in regexp");
2498	/* FALL THROUGH */
2499	default:
2500	/* Do not generate `unrecognized' warnings here, we fall
2501	back into the quick-grab loop below */
2502	goto defchar;
2503	}
2504	break;
2505
2506	case '#':
2507	if (PL_regflags & PMf_EXTENDED) {
2508	while (PL_regcomp_parse < PL_regxend && *PL_regcomp_parse != '\n') PL_regcomp_parse++;
2509	if (PL_regcomp_parse < PL_regxend)
2510	goto tryagain;
2511	}
2512	/* FALL THROUGH */
2513
2514	default: {
2515	register I32 len;
2516	register UV ender;
2517	register char *p;
2518	char oldp, s;
2519	I32 numlen;
2520
2521	PL_regcomp_parse++;
2522
2523	defchar:
2524	ret = reg_node(FOLD
2525	? (LOC ? EXACTFL : EXACTF)
2526	: EXACT);
2527	s = STRING(ret);
2528	for (len = 0, p = PL_regcomp_parse - 1;
2529	len < 127 && p < PL_regxend;
2530	len++)
2531	{
2532	oldp = p;
2533
2534	if (PL_regflags & PMf_EXTENDED)
2535	p = regwhite(p, PL_regxend);
2536	switch (*p) {
2537	case '^':
2538	case '$':
2539	case '.':
2540	case '[':
2541	case '(':
2542	case ')':
2543	case '\|':
2544	goto loopdone;
2545	case '\\':
2546	switch (*++p) {
2547	case 'A':
2548	case 'G':
2549	case 'Z':
2550	case 'z':
2551	case 'w':
2552	case 'W':
2553	case 'b':
2554	case 'B':
2555	case 's':
2556	case 'S':
2557	case 'd':
2558	case 'D':
2559	case 'p':
2560	case 'P':
2561	--p;
2562	goto loopdone;
2563	case 'n':
2564	ender = '\n';
2565	p++;
2566	break;
2567	case 'r':
2568	ender = '\r';
2569	p++;
2570	break;
2571	case 't':
2572	ender = '\t';
2573	p++;
2574	break;
2575	case 'f':
2576	ender = '\f';
2577	p++;
2578	break;
2579	case 'e':
2580	#ifdef ASCIIish
2581	ender = '\033';
2582	#else
2583	ender = '\047';
2584	#endif
2585	p++;
2586	break;
2587	case 'a':
2588	#ifdef ASCIIish
2589	ender = '\007';
2590	#else
2591	ender = '\057';
2592	#endif
2593	p++;
2594	break;
2595	case 'x':
2596	if (*++p == '{') {
2597	char* e = strchr(p, '}');
2598
2599	if (!e)
2600	FAIL("Missing right brace on \\x{}");
2601	else if (UTF) {
2602	ender = (UV)scan_hex(p + 1, e - p, &numlen);
2603	if (numlen + len >= 127) { /* numlen is generous */
2604	p--;
2605	goto loopdone;
2606	}
2607	p = e + 1;
2608	}
2609	else
2610	FAIL("Can't use \\x{} without 'use utf8' declaration");
2611	}
2612	else {
2613	ender = (UV)scan_hex(p, 2, &numlen);
2614	p += numlen;
2615	}
2616	break;
2617	case 'c':
2618	p++;
2619	ender = UCHARAT(p++);
2620	ender = toCTRL(ender);
2621	break;
2622	case '0': case '1': case '2': case '3':case '4':
2623	case '5': case '6': case '7': case '8':case '9':
2624	if (*p == '0' \|\|
2625	(isDIGIT(p[1]) && atoi(p) >= PL_regnpar) ) {
2626	ender = (UV)scan_oct(p, 3, &numlen);
2627	p += numlen;
2628	}
2629	else {
2630	--p;
2631	goto loopdone;
2632	}
2633	break;
2634	case '\0':
2635	if (p >= PL_regxend)
2636	FAIL("trailing \\ in regexp");
2637	/* FALL THROUGH */
2638	default:
2639	if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && isALPHA(*p))
2640	Perl_warner(aTHX_ WARN_REGEXP,
2641	"/%.127s/: Unrecognized escape \\%c passed through",
2642	PL_regprecomp,
2643	*p);
2644	goto normal_default;
2645	}
2646	break;
2647	default:
2648	normal_default:
2649	if ((*p & 0xc0) == 0xc0 && UTF) {
2650	ender = utf8_to_uv((U8*)p, &numlen);
2651	p += numlen;
2652	}
2653	else
2654	ender = *p++;
2655	break;
2656	}
2657	if (PL_regflags & PMf_EXTENDED)
2658	p = regwhite(p, PL_regxend);
2659	if (UTF && FOLD) {
2660	if (LOC)
2661	ender = toLOWER_LC_uni(ender);
2662	else
2663	ender = toLOWER_uni(ender);
2664	}
2665	if (ISMULT2(p)) { /* Back off on ?+. /
2666	if (len)
2667	p = oldp;
2668	else if (ender >= 0x80 && UTF) {
2669	reguni(ender, s, &numlen);
2670	s += numlen;
2671	len += numlen;
2672	}
2673	else {
2674	len++;
2675	REGC(ender, s++);
2676	}
2677	break;
2678	}
2679	if (ender >= 0x80 && UTF) {
2680	reguni(ender, s, &numlen);
2681	s += numlen;
2682	len += numlen - 1;
2683	}
2684	else
2685	REGC(ender, s++);
2686	}
2687	loopdone:
2688	PL_regcomp_parse = p - 1;
2689	nextchar();
2690	if (len < 0)
2691	FAIL("internal disaster in regexp");
2692	if (len > 0)
2693	*flagp \|= HASWIDTH;
2694	if (len == 1)
2695	*flagp \|= SIMPLE;
2696	if (!SIZE_ONLY)
2697	STR_LEN(ret) = len;
2698	if (SIZE_ONLY)
2699	PL_regsize += STR_SZ(len);
2700	else
2701	PL_regcode += STR_SZ(len);
2702	}
2703	break;
2704	}
2705
2706	return(ret);
2707	}
2708
2709	STATIC char *
2710	S_regwhite(pTHX_ char p, char e)
2711	{
2712	while (p < e) {
2713	if (isSPACE(*p))
2714	++p;
2715	else if (*p == '#') {
2716	do {
2717	p++;
2718	} while (p < e && *p != '\n');
2719	}
2720	else
2721	break;
2722	}
2723	return p;
2724	}
2725
2726	/* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
2727	Character classes ([:foo:]) can also be negated ([:^foo:]).
2728	Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
2729	Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
2730	but trigger warnings because they are currently unimplemented. */
2731	STATIC I32
2732	S_regpposixcc(pTHX_ I32 value)
2733	{
2734	dTHR;
2735	char *posixcc = 0;
2736	I32 namedclass = OOB_NAMEDCLASS;
2737
2738	if (value == '[' && PL_regcomp_parse + 1 < PL_regxend &&
2739	/* I smell either [: or [= or [. -- POSIX has been here, right? */
2740	(*PL_regcomp_parse == ':' \|\|
2741	*PL_regcomp_parse == '=' \|\|
2742	*PL_regcomp_parse == '.')) {
2743	char c = *PL_regcomp_parse;
2744	char* s = PL_regcomp_parse++;
2745
2746	while (PL_regcomp_parse < PL_regxend && *PL_regcomp_parse != c)
2747	PL_regcomp_parse++;
2748	if (PL_regcomp_parse == PL_regxend)
2749	/* Grandfather lone [:, [=, [. */
2750	PL_regcomp_parse = s;
2751	else {
2752	char* t = PL_regcomp_parse++; /* skip over the c */
2753
2754	if (*PL_regcomp_parse == ']') {
2755	PL_regcomp_parse++; /* skip over the ending ] */
2756	posixcc = s + 1;
2757	if (*s == ':') {
2758	I32 complement = posixcc == '^' ? posixcc++ : 0;
2759	I32 skip = 5; /* the most common skip */
2760
2761	switch (*posixcc) {
2762	case 'a':
2763	if (strnEQ(posixcc, "alnum", 5))
2764	namedclass =
2765	complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
2766	else if (strnEQ(posixcc, "alpha", 5))
2767	namedclass =
2768	complement ? ANYOF_NALPHA : ANYOF_ALPHA;
2769	else if (strnEQ(posixcc, "ascii", 5))
2770	namedclass =
2771	complement ? ANYOF_NASCII : ANYOF_ASCII;
2772	break;
2773	case 'c':
2774	if (strnEQ(posixcc, "cntrl", 5))
2775	namedclass =
2776	complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
2777	break;
2778	case 'd':
2779	if (strnEQ(posixcc, "digit", 5))
2780	namedclass =
2781	complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
2782	break;
2783	case 'g':
2784	if (strnEQ(posixcc, "graph", 5))
2785	namedclass =
2786	complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
2787	break;
2788	case 'l':
2789	if (strnEQ(posixcc, "lower", 5))
2790	namedclass =
2791	complement ? ANYOF_NLOWER : ANYOF_LOWER;
2792	break;
2793	case 'p':
2794	if (strnEQ(posixcc, "print", 5))
2795	namedclass =
2796	complement ? ANYOF_NPRINT : ANYOF_PRINT;
2797	else if (strnEQ(posixcc, "punct", 5))
2798	namedclass =
2799	complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
2800	break;
2801	case 's':
2802	if (strnEQ(posixcc, "space", 5))
2803	namedclass =
2804	complement ? ANYOF_NSPACE : ANYOF_SPACE;
2805	case 'u':
2806	if (strnEQ(posixcc, "upper", 5))
2807	namedclass =
2808	complement ? ANYOF_NUPPER : ANYOF_UPPER;
2809	break;
2810	case 'w': /* this is not POSIX, this is the Perl \w */
2811	if (strnEQ(posixcc, "word", 4)) {
2812	namedclass =
2813	complement ? ANYOF_NALNUM : ANYOF_ALNUM;
2814	skip = 4;
2815	}
2816	break;
2817	case 'x':
2818	if (strnEQ(posixcc, "xdigit", 6)) {
2819	namedclass =
2820	complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
2821	skip = 6;
2822	}
2823	break;
2824	}
2825	if (namedclass == OOB_NAMEDCLASS \|\|
2826	posixcc[skip] != ':' \|\|
2827	posixcc[skip+1] != ']')
2828	Perl_croak(aTHX_
2829	"Character class [:%.*s:] unknown",
2830	t - s - 1, s + 1);
2831	} else if (ckWARN(WARN_REGEXP) && !SIZE_ONLY)
2832	/* [[=foo=]] and [[.foo.]] are still future. */
2833	Perl_warner(aTHX_ WARN_REGEXP,
2834	"Character class syntax [%c %c] is reserved for future extensions", c, c);
2835	} else {
2836	/* Maternal grandfather:
2837	* "[:" ending in ":" but not in ":]" */
2838	PL_regcomp_parse = s;
2839	}
2840	}
2841	}
2842
2843	return namedclass;
2844	}
2845
2846	STATIC void
2847	S_checkposixcc(pTHX)
2848	{
2849	if (!SIZE_ONLY && ckWARN(WARN_REGEXP) &&
2850	(*PL_regcomp_parse == ':' \|\|
2851	*PL_regcomp_parse == '=' \|\|
2852	*PL_regcomp_parse == '.')) {
2853	char *s = PL_regcomp_parse;
2854	char c = *s++;
2855
2856	while(s && isALNUM(s))
2857	s++;
2858	if (s && c == s && s[1] == ']') {
2859	Perl_warner(aTHX_ WARN_REGEXP,
2860	"Character class syntax [%c %c] belongs inside character classes", c, c);
2861	if (c == '=' \|\| c == '.')
2862	Perl_warner(aTHX_ WARN_REGEXP,
2863	"Character class syntax [%c %c] is reserved for future extensions", c, c);
2864	}
2865	}
2866	}
2867
2868	STATIC regnode *
2869	S_regclass(pTHX)
2870	{
2871	dTHR;
2872	register U32 value;
2873	register I32 lastvalue = OOB_CHAR8;
2874	register I32 range = 0;
2875	register regnode *ret;
2876	I32 numlen;
2877	I32 namedclass;
2878	char *rangebegin;
2879	bool need_class = 0;
2880
2881	ret = reg_node(ANYOF);
2882	if (SIZE_ONLY)
2883	PL_regsize += ANYOF_SKIP;
2884	else {
2885	ret->flags = 0;
2886	ANYOF_BITMAP_ZERO(ret);
2887	PL_regcode += ANYOF_SKIP;
2888	if (FOLD)
2889	ANYOF_FLAGS(ret) \|= ANYOF_FOLD;
2890	if (LOC)
2891	ANYOF_FLAGS(ret) \|= ANYOF_LOCALE;
2892	}
2893	if (PL_regcomp_parse == '^') { / Complement of range. */
2894	PL_regnaughty++;
2895	PL_regcomp_parse++;
2896	if (!SIZE_ONLY)
2897	ANYOF_FLAGS(ret) \|= ANYOF_INVERT;
2898	}
2899
2900	if (!SIZE_ONLY && ckWARN(WARN_REGEXP))
2901	checkposixcc();
2902
2903	if (PL_regcomp_parse == ']' \|\| PL_regcomp_parse == '-')
2904	goto skipcond; /* allow 1st char to be ] or - */
2905	while (PL_regcomp_parse < PL_regxend && *PL_regcomp_parse != ']') {
2906	skipcond:
2907	namedclass = OOB_NAMEDCLASS;
2908	if (!range)
2909	rangebegin = PL_regcomp_parse;
2910	value = UCHARAT(PL_regcomp_parse++);
2911	if (value == '[')
2912	namedclass = regpposixcc(value);
2913	else if (value == '\\') {
2914	value = UCHARAT(PL_regcomp_parse++);
2915	/* Some compilers cannot handle switching on 64-bit integer
2916	* values, therefore value cannot be an UV. --jhi */
2917	switch (value) {
2918	case 'w': namedclass = ANYOF_ALNUM; break;
2919	case 'W': namedclass = ANYOF_NALNUM; break;
2920	case 's': namedclass = ANYOF_SPACE; break;
2921	case 'S': namedclass = ANYOF_NSPACE; break;
2922	case 'd': namedclass = ANYOF_DIGIT; break;
2923	case 'D': namedclass = ANYOF_NDIGIT; break;
2924	case 'n': value = '\n'; break;
2925	case 'r': value = '\r'; break;
2926	case 't': value = '\t'; break;
2927	case 'f': value = '\f'; break;
2928	case 'b': value = '\b'; break;
2929	#ifdef ASCIIish
2930	case 'e': value = '\033'; break;
2931	case 'a': value = '\007'; break;
2932	#else
2933	case 'e': value = '\047'; break;
2934	case 'a': value = '\057'; break;
2935	#endif
2936	case 'x':
2937	value = (UV)scan_hex(PL_regcomp_parse, 2, &numlen);
2938	PL_regcomp_parse += numlen;
2939	break;
2940	case 'c':
2941	value = UCHARAT(PL_regcomp_parse++);
2942	value = toCTRL(value);
2943	break;
2944	case '0': case '1': case '2': case '3': case '4':
2945	case '5': case '6': case '7': case '8': case '9':
2946	value = (UV)scan_oct(--PL_regcomp_parse, 3, &numlen);
2947	PL_regcomp_parse += numlen;
2948	break;
2949	default:
2950	if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && isALPHA(value))
2951	Perl_warner(aTHX_ WARN_REGEXP,
2952	"/%.127s/: Unrecognized escape \\%c in character class passed through",
2953	PL_regprecomp,
2954	(int)value);
2955	break;
2956	}
2957	}
2958	if (namedclass > OOB_NAMEDCLASS) {
2959	if (!need_class && !SIZE_ONLY)
2960	ANYOF_CLASS_ZERO(ret);
2961	need_class = 1;
2962	if (range) { /* a-\d, a-[:digit:] */
2963	if (!SIZE_ONLY) {
2964	if (ckWARN(WARN_REGEXP))
2965	Perl_warner(aTHX_ WARN_REGEXP,
2966	"/%.127s/: false [] range \"%.s\" in regexp",
2967	PL_regprecomp,
2968	PL_regcomp_parse - rangebegin,
2969	PL_regcomp_parse - rangebegin,
2970	rangebegin);
2971	ANYOF_BITMAP_SET(ret, lastvalue);
2972	ANYOF_BITMAP_SET(ret, '-');
2973	}
2974	range = 0; /* this is not a true range */
2975	}
2976	if (!SIZE_ONLY) {
2977	switch (namedclass) {
2978	case ANYOF_ALNUM:
2979	if (LOC)
2980	ANYOF_CLASS_SET(ret, ANYOF_ALNUM);
2981	else {
2982	for (value = 0; value < 256; value++)
2983	if (isALNUM(value))
2984	ANYOF_BITMAP_SET(ret, value);
2985	}
2986	break;
2987	case ANYOF_NALNUM:
2988	if (LOC)
2989	ANYOF_CLASS_SET(ret, ANYOF_NALNUM);
2990	else {
2991	for (value = 0; value < 256; value++)
2992	if (!isALNUM(value))
2993	ANYOF_BITMAP_SET(ret, value);
2994	}
2995	break;
2996	case ANYOF_SPACE:
2997	if (LOC)
2998	ANYOF_CLASS_SET(ret, ANYOF_SPACE);
2999	else {
3000	for (value = 0; value < 256; value++)
3001	if (isSPACE(value))
3002	ANYOF_BITMAP_SET(ret, value);
3003	}
3004	break;
3005	case ANYOF_NSPACE:
3006	if (LOC)
3007	ANYOF_CLASS_SET(ret, ANYOF_NSPACE);
3008	else {
3009	for (value = 0; value < 256; value++)
3010	if (!isSPACE(value))
3011	ANYOF_BITMAP_SET(ret, value);
3012	}
3013	break;
3014	case ANYOF_DIGIT:
3015	if (LOC)
3016	ANYOF_CLASS_SET(ret, ANYOF_DIGIT);
3017	else {
3018	for (value = '0'; value <= '9'; value++)
3019	ANYOF_BITMAP_SET(ret, value);
3020	}
3021	break;
3022	case ANYOF_NDIGIT:
3023	if (LOC)
3024	ANYOF_CLASS_SET(ret, ANYOF_NDIGIT);
3025	else {
3026	for (value = 0; value < '0'; value++)
3027	ANYOF_BITMAP_SET(ret, value);
3028	for (value = '9' + 1; value < 256; value++)
3029	ANYOF_BITMAP_SET(ret, value);
3030	}
3031	break;
3032	case ANYOF_NALNUMC:
3033	if (LOC)
3034	ANYOF_CLASS_SET(ret, ANYOF_NALNUMC);
3035	else {
3036	for (value = 0; value < 256; value++)
3037	if (!isALNUMC(value))
3038	ANYOF_BITMAP_SET(ret, value);
3039	}
3040	break;
3041	case ANYOF_ALNUMC:
3042	if (LOC)
3043	ANYOF_CLASS_SET(ret, ANYOF_ALNUMC);
3044	else {
3045	for (value = 0; value < 256; value++)
3046	if (isALNUMC(value))
3047	ANYOF_BITMAP_SET(ret, value);
3048	}
3049	break;
3050	case ANYOF_ALPHA:
3051	if (LOC)
3052	ANYOF_CLASS_SET(ret, ANYOF_ALPHA);
3053	else {
3054	for (value = 0; value < 256; value++)
3055	if (isALPHA(value))
3056	ANYOF_BITMAP_SET(ret, value);
3057	}
3058	break;
3059	case ANYOF_NALPHA:
3060	if (LOC)
3061	ANYOF_CLASS_SET(ret, ANYOF_NALPHA);
3062	else {
3063	for (value = 0; value < 256; value++)
3064	if (!isALPHA(value))
3065	ANYOF_BITMAP_SET(ret, value);
3066	}
3067	break;
3068	case ANYOF_ASCII:
3069	if (LOC)
3070	ANYOF_CLASS_SET(ret, ANYOF_ASCII);
3071	else {
3072	#ifdef ASCIIish
3073	for (value = 0; value < 128; value++)
3074	ANYOF_BITMAP_SET(ret, value);
3075	#else /* EBCDIC */
3076	for (value = 0; value < 256; value++)
3077	if (isASCII(value))
3078	ANYOF_BITMAP_SET(ret, value);
3079	#endif /* EBCDIC */
3080	}
3081	break;
3082	case ANYOF_NASCII:
3083	if (LOC)
3084	ANYOF_CLASS_SET(ret, ANYOF_NASCII);
3085	else {
3086	#ifdef ASCIIish
3087	for (value = 128; value < 256; value++)
3088	ANYOF_BITMAP_SET(ret, value);
3089	#else /* EBCDIC */
3090	for (value = 0; value < 256; value++)
3091	if (!isASCII(value))
3092	ANYOF_BITMAP_SET(ret, value);
3093	#endif /* EBCDIC */
3094	}
3095	break;
3096	case ANYOF_CNTRL:
3097	if (LOC)
3098	ANYOF_CLASS_SET(ret, ANYOF_CNTRL);
3099	else {
3100	for (value = 0; value < 256; value++)
3101	if (isCNTRL(value))
3102	ANYOF_BITMAP_SET(ret, value);
3103	}
3104	lastvalue = OOB_CHAR8;
3105	break;
3106	case ANYOF_NCNTRL:
3107	if (LOC)
3108	ANYOF_CLASS_SET(ret, ANYOF_NCNTRL);
3109	else {
3110	for (value = 0; value < 256; value++)
3111	if (!isCNTRL(value))
3112	ANYOF_BITMAP_SET(ret, value);
3113	}
3114	break;
3115	case ANYOF_GRAPH:
3116	if (LOC)
3117	ANYOF_CLASS_SET(ret, ANYOF_GRAPH);
3118	else {
3119	for (value = 0; value < 256; value++)
3120	if (isGRAPH(value))
3121	ANYOF_BITMAP_SET(ret, value);
3122	}
3123	break;
3124	case ANYOF_NGRAPH:
3125	if (LOC)
3126	ANYOF_CLASS_SET(ret, ANYOF_NGRAPH);
3127	else {
3128	for (value = 0; value < 256; value++)
3129	if (!isGRAPH(value))
3130	ANYOF_BITMAP_SET(ret, value);
3131	}
3132	break;
3133	case ANYOF_LOWER:
3134	if (LOC)
3135	ANYOF_CLASS_SET(ret, ANYOF_LOWER);
3136	else {
3137	for (value = 0; value < 256; value++)
3138	if (isLOWER(value))
3139	ANYOF_BITMAP_SET(ret, value);
3140	}
3141	break;
3142	case ANYOF_NLOWER:
3143	if (LOC)
3144	ANYOF_CLASS_SET(ret, ANYOF_NLOWER);
3145	else {
3146	for (value = 0; value < 256; value++)
3147	if (!isLOWER(value))
3148	ANYOF_BITMAP_SET(ret, value);
3149	}
3150	break;
3151	case ANYOF_PRINT:
3152	if (LOC)
3153	ANYOF_CLASS_SET(ret, ANYOF_PRINT);
3154	else {
3155	for (value = 0; value < 256; value++)
3156	if (isPRINT(value))
3157	ANYOF_BITMAP_SET(ret, value);
3158	}
3159	break;
3160	case ANYOF_NPRINT:
3161	if (LOC)
3162	ANYOF_CLASS_SET(ret, ANYOF_NPRINT);
3163	else {
3164	for (value = 0; value < 256; value++)
3165	if (!isPRINT(value))
3166	ANYOF_BITMAP_SET(ret, value);
3167	}
3168	break;
3169	case ANYOF_PUNCT:
3170	if (LOC)
3171	ANYOF_CLASS_SET(ret, ANYOF_PUNCT);
3172	else {
3173	for (value = 0; value < 256; value++)
3174	if (isPUNCT(value))
3175	ANYOF_BITMAP_SET(ret, value);
3176	}
3177	break;
3178	case ANYOF_NPUNCT:
3179	if (LOC)
3180	ANYOF_CLASS_SET(ret, ANYOF_NPUNCT);
3181	else {
3182	for (value = 0; value < 256; value++)
3183	if (!isPUNCT(value))
3184	ANYOF_BITMAP_SET(ret, value);
3185	}
3186	break;
3187	case ANYOF_UPPER:
3188	if (LOC)
3189	ANYOF_CLASS_SET(ret, ANYOF_UPPER);
3190	else {
3191	for (value = 0; value < 256; value++)
3192	if (isUPPER(value))
3193	ANYOF_BITMAP_SET(ret, value);
3194	}
3195	break;
3196	case ANYOF_NUPPER:
3197	if (LOC)
3198	ANYOF_CLASS_SET(ret, ANYOF_NUPPER);
3199	else {
3200	for (value = 0; value < 256; value++)
3201	if (!isUPPER(value))
3202	ANYOF_BITMAP_SET(ret, value);
3203	}
3204	break;
3205	case ANYOF_XDIGIT:
3206	if (LOC)
3207	ANYOF_CLASS_SET(ret, ANYOF_XDIGIT);
3208	else {
3209	for (value = 0; value < 256; value++)
3210	if (isXDIGIT(value))
3211	ANYOF_BITMAP_SET(ret, value);
3212	}
3213	break;
3214	case ANYOF_NXDIGIT:
3215	if (LOC)
3216	ANYOF_CLASS_SET(ret, ANYOF_NXDIGIT);
3217	else {
3218	for (value = 0; value < 256; value++)
3219	if (!isXDIGIT(value))
3220	ANYOF_BITMAP_SET(ret, value);
3221	}
3222	break;
3223	default:
3224	FAIL("invalid [::] class in regexp");
3225	break;
3226	}
3227	if (LOC)
3228	ANYOF_FLAGS(ret) \|= ANYOF_CLASS;
3229	continue;
3230	}
3231	}
3232	if (range) {
3233	if (lastvalue > value) /* b-a */ {
3234	Perl_croak(aTHX_
3235	"/%.127s/: invalid [] range \"%.s\" in regexp",
3236	PL_regprecomp,
3237	PL_regcomp_parse - rangebegin,
3238	PL_regcomp_parse - rangebegin,
3239	rangebegin);
3240	}
3241	range = 0;
3242	}
3243	else {
3244	lastvalue = value;
3245	if (*PL_regcomp_parse == '-' && PL_regcomp_parse+1 < PL_regxend &&
3246	PL_regcomp_parse[1] != ']') {
3247	PL_regcomp_parse++;
3248	if (namedclass > OOB_NAMEDCLASS) { /* \w-, [:word:]- */
3249	if (ckWARN(WARN_REGEXP))
3250	Perl_warner(aTHX_ WARN_REGEXP,
3251	"/%.127s/: false [] range \"%.s\" in regexp",
3252	PL_regprecomp,
3253	PL_regcomp_parse - rangebegin,
3254	PL_regcomp_parse - rangebegin,
3255	rangebegin);
3256	if (!SIZE_ONLY)
3257	ANYOF_BITMAP_SET(ret, '-');
3258	} else
3259	range = 1;
3260	continue; /* do it next time */
3261	}
3262	}
3263	/* now is the next time */
3264	if (!SIZE_ONLY) {
3265	#ifndef ASCIIish /* EBCDIC, for example. */
3266	if ((isLOWER(lastvalue) && isLOWER(value)) \|\|
3267	(isUPPER(lastvalue) && isUPPER(value)))
3268	{
3269	I32 i;
3270	if (isLOWER(lastvalue)) {
3271	for (i = lastvalue; i <= value; i++)
3272	if (isLOWER(i))
3273	ANYOF_BITMAP_SET(ret, i);
3274	} else {
3275	for (i = lastvalue; i <= value; i++)
3276	if (isUPPER(i))
3277	ANYOF_BITMAP_SET(ret, i);
3278	}
3279	}
3280	else
3281	#endif
3282	for ( ; lastvalue <= value; lastvalue++)
3283	ANYOF_BITMAP_SET(ret, lastvalue);
3284	}
3285	range = 0;
3286	}
3287	if (need_class) {
3288	if (SIZE_ONLY)
3289	PL_regsize += ANYOF_CLASS_ADD_SKIP;
3290	else
3291	PL_regcode += ANYOF_CLASS_ADD_SKIP;
3292	}
3293	/* optimize case-insensitive simple patterns (e.g. /[a-z]/i) */
3294	if (!SIZE_ONLY &&
3295	(ANYOF_FLAGS(ret) & (ANYOF_FLAGS_ALL ^ ANYOF_INVERT)) == ANYOF_FOLD) {
3296	for (value = 0; value < 256; ++value) {
3297	if (ANYOF_BITMAP_TEST(ret, value)) {
3298	I32 cf = PL_fold[value];
3299	ANYOF_BITMAP_SET(ret, cf);
3300	}
3301	}
3302	ANYOF_FLAGS(ret) &= ~ANYOF_FOLD;
3303	}
3304	/* optimize inverted simple patterns (e.g. [^a-z]) */
3305	if (!SIZE_ONLY && (ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT) {
3306	for (value = 0; value < ANYOF_BITMAP_SIZE; ++value)
3307	ANYOF_BITMAP(ret)[value] ^= ANYOF_FLAGS_ALL;
3308	ANYOF_FLAGS(ret) = 0;
3309	}
3310	return ret;
3311	}
3312
3313	STATIC regnode *
3314	S_regclassutf8(pTHX)
3315	{
3316	dTHR;
3317	register char *e;
3318	register U32 value;
3319	register U32 lastvalue = OOB_UTF8;
3320	register I32 range = 0;
3321	register regnode *ret;
3322	I32 numlen;
3323	I32 n;
3324	SV *listsv;
3325	U8 flags = 0;
3326	I32 namedclass;
3327	char *rangebegin;
3328
3329	if (PL_regcomp_parse == '^') { / Complement of range. */
3330	PL_regnaughty++;
3331	PL_regcomp_parse++;
3332	if (!SIZE_ONLY)
3333	flags \|= ANYOF_INVERT;
3334	}
3335	if (!SIZE_ONLY) {
3336	if (FOLD)
3337	flags \|= ANYOF_FOLD;
3338	if (LOC)
3339	flags \|= ANYOF_LOCALE;
3340	listsv = newSVpvn("# comment\n",10);
3341	}
3342
3343	if (!SIZE_ONLY && ckWARN(WARN_REGEXP))
3344	checkposixcc();
3345
3346	if (PL_regcomp_parse == ']' \|\| PL_regcomp_parse == '-')
3347	goto skipcond; /* allow 1st char to be ] or - */
3348
3349	while (PL_regcomp_parse < PL_regxend && *PL_regcomp_parse != ']') {
3350	skipcond:
3351	namedclass = OOB_NAMEDCLASS;
3352	if (!range)
3353	rangebegin = PL_regcomp_parse;
3354	value = utf8_to_uv((U8*)PL_regcomp_parse, &numlen);
3355	PL_regcomp_parse += numlen;
3356	if (value == '[')
3357	namedclass = regpposixcc(value);
3358	else if (value == '\\') {
3359	value = (U32)utf8_to_uv((U8*)PL_regcomp_parse, &numlen);
3360	PL_regcomp_parse += numlen;
3361	/* Some compilers cannot handle switching on 64-bit integer
3362	* values, therefore value cannot be an UV. Yes, this will
3363	* be a problem later if we want switch on Unicode. --jhi */
3364	switch (value) {
3365	case 'w': namedclass = ANYOF_ALNUM; break;
3366	case 'W': namedclass = ANYOF_NALNUM; break;
3367	case 's': namedclass = ANYOF_SPACE; break;
3368	case 'S': namedclass = ANYOF_NSPACE; break;
3369	case 'd': namedclass = ANYOF_DIGIT; break;
3370	case 'D': namedclass = ANYOF_NDIGIT; break;
3371	case 'p':
3372	case 'P':
3373	if (*PL_regcomp_parse == '{') {
3374	e = strchr(PL_regcomp_parse++, '}');
3375	if (!e)
3376	FAIL("Missing right brace on \\p{}");
3377	n = e - PL_regcomp_parse;
3378	}
3379	else {
3380	e = PL_regcomp_parse;
3381	n = 1;
3382	}
3383	if (!SIZE_ONLY) {
3384	if (value == 'p')
3385	Perl_sv_catpvf(aTHX_ listsv,
3386	"+utf8::%.*s\n", (int)n, PL_regcomp_parse);
3387	else
3388	Perl_sv_catpvf(aTHX_ listsv,
3389	"!utf8::%.*s\n", (int)n, PL_regcomp_parse);
3390	}
3391	PL_regcomp_parse = e + 1;
3392	lastvalue = OOB_UTF8;
3393	continue;
3394	case 'n': value = '\n'; break;
3395	case 'r': value = '\r'; break;
3396	case 't': value = '\t'; break;
3397	case 'f': value = '\f'; break;
3398	case 'b': value = '\b'; break;
3399	#ifdef ASCIIish
3400	case 'e': value = '\033'; break;
3401	case 'a': value = '\007'; break;
3402	#else
3403	case 'e': value = '\047'; break;
3404	case 'a': value = '\057'; break;
3405	#endif
3406	case 'x':
3407	if (*PL_regcomp_parse == '{') {
3408	e = strchr(PL_regcomp_parse++, '}');
3409	if (!e)
3410	FAIL("Missing right brace on \\x{}");
3411	value = (UV)scan_hex(PL_regcomp_parse,
3412	e - PL_regcomp_parse,
3413	&numlen);
3414	PL_regcomp_parse = e + 1;
3415	}
3416	else {
3417	value = (UV)scan_hex(PL_regcomp_parse, 2, &numlen);
3418	PL_regcomp_parse += numlen;
3419	}
3420	break;
3421	case 'c':
3422	value = UCHARAT(PL_regcomp_parse++);
3423	value = toCTRL(value);
3424	break;
3425	case '0': case '1': case '2': case '3': case '4':
3426	case '5': case '6': case '7': case '8': case '9':
3427	value = (UV)scan_oct(--PL_regcomp_parse, 3, &numlen);
3428	PL_regcomp_parse += numlen;
3429	break;
3430	default:
3431	if (!SIZE_ONLY && ckWARN(WARN_REGEXP) && isALPHA(value))
3432	Perl_warner(aTHX_ WARN_REGEXP,
3433	"/%.127s/: Unrecognized escape \\%c in character class passed through",
3434	PL_regprecomp,
3435	(int)value);
3436	break;
3437	}
3438	}
3439	if (namedclass > OOB_NAMEDCLASS) {
3440	if (range) { /* a-\d, a-[:digit:] */
3441	if (!SIZE_ONLY) {
3442	if (ckWARN(WARN_REGEXP))
3443	Perl_warner(aTHX_ WARN_REGEXP,
3444	"/%.127s/: false [] range \"%.s\" in regexp",
3445	PL_regprecomp,
3446	PL_regcomp_parse - rangebegin,
3447	PL_regcomp_parse - rangebegin,
3448	rangebegin);
3449	Perl_sv_catpvf(aTHX_ listsv,
3450	/* 0x002D is Unicode for '-' */
3451	"%04"UVxf"\n002D\n", (UV)lastvalue);
3452	}
3453	range = 0;
3454	}
3455	if (!SIZE_ONLY) {
3456	switch (namedclass) {
3457	case ANYOF_ALNUM:
3458	Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsWord\n"); break;
3459	case ANYOF_NALNUM:
3460	Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsWord\n"); break;
3461	case ANYOF_ALNUMC:
3462	Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsAlnum\n"); break;
3463	case ANYOF_NALNUMC:
3464	Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsAlnum\n"); break;
3465	case ANYOF_ALPHA:
3466	Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsAlpha\n"); break;
3467	case ANYOF_NALPHA:
3468	Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsAlpha\n"); break;
3469	case ANYOF_ASCII:
3470	Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsASCII\n"); break;
3471	case ANYOF_NASCII:
3472	Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsASCII\n"); break;
3473	case ANYOF_CNTRL:
3474	Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsCntrl\n"); break;
3475	case ANYOF_NCNTRL:
3476	Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsCntrl\n"); break;
3477	case ANYOF_GRAPH:
3478	Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsGraph\n"); break;
3479	case ANYOF_NGRAPH:
3480	Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsGraph\n"); break;
3481	case ANYOF_DIGIT:
3482	Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsDigit\n"); break;
3483	case ANYOF_NDIGIT:
3484	Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsDigit\n"); break;
3485	case ANYOF_LOWER:
3486	Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsLower\n"); break;
3487	case ANYOF_NLOWER:
3488	Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsLower\n"); break;
3489	case ANYOF_PRINT:
3490	Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsPrint\n"); break;
3491	case ANYOF_NPRINT:
3492	Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsPrint\n"); break;
3493	case ANYOF_PUNCT:
3494	Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsPunct\n"); break;
3495	case ANYOF_NPUNCT:
3496	Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsPunct\n"); break;
3497	case ANYOF_SPACE:
3498	Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsSpace\n"); break;
3499	case ANYOF_NSPACE:
3500	Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsSpace\n"); break;
3501	case ANYOF_UPPER:
3502	Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsUpper\n"); break;
3503	case ANYOF_NUPPER:
3504	Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsUpper\n"); break;
3505	case ANYOF_XDIGIT:
3506	Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsXDigit\n"); break;
3507	case ANYOF_NXDIGIT:
3508	Perl_sv_catpvf(aTHX_ listsv, "!utf8::IsXDigit\n"); break;
3509	}
3510	continue;
3511	}
3512	}
3513	if (range) {
3514	if (lastvalue > value) { /* b-a */
3515	Perl_croak(aTHX_
3516	"/%.127s/: invalid [] range \"%.s\" in regexp",
3517	PL_regprecomp,
3518	PL_regcomp_parse - rangebegin,
3519	PL_regcomp_parse - rangebegin,
3520	rangebegin);
3521	}
3522	range = 0;
3523	}
3524	else {
3525	lastvalue = value;
3526	if (*PL_regcomp_parse == '-' && PL_regcomp_parse+1 < PL_regxend &&
3527	PL_regcomp_parse[1] != ']') {
3528	PL_regcomp_parse++;
3529	if (namedclass > OOB_NAMEDCLASS) { /* \w-, [:word:]- */
3530	if (ckWARN(WARN_REGEXP))
3531	Perl_warner(aTHX_ WARN_REGEXP,
3532	"/%.127s/: false [] range \"%.s\" in regexp",
3533	PL_regprecomp,
3534	PL_regcomp_parse - rangebegin,
3535	PL_regcomp_parse - rangebegin,
3536	rangebegin);
3537	if (!SIZE_ONLY)
3538	Perl_sv_catpvf(aTHX_ listsv,
3539	/* 0x002D is Unicode for '-' */
3540	"002D\n");
3541	} else
3542	range = 1;
3543	continue; /* do it next time */
3544	}
3545	}
3546	/* now is the next time */
3547	if (!SIZE_ONLY)
3548	Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
3549	(UV)lastvalue, (UV)value);
3550	range = 0;
3551	}
3552
3553	ret = reganode(ANYOFUTF8, 0);
3554
3555	if (!SIZE_ONLY) {
3556	SV *rv = swash_init("utf8", "", listsv, 1, 0);
3557	SvREFCNT_dec(listsv);
3558	n = add_data(1,"s");
3559	PL_regcomp_rx->data->data[n] = (void*)rv;
3560	ARG1_SET(ret, flags);
3561	ARG2_SET(ret, n);
3562	}
3563
3564	return ret;
3565	}
3566
3567	STATIC char*
3568	S_nextchar(pTHX)
3569	{
3570	dTHR;
3571	char* retval = PL_regcomp_parse++;
3572
3573	for (;;) {
3574	if (*PL_regcomp_parse == '(' && PL_regcomp_parse[1] == '?' &&
3575	PL_regcomp_parse[2] == '#') {
3576	while (PL_regcomp_parse && PL_regcomp_parse != ')')
3577	PL_regcomp_parse++;
3578	PL_regcomp_parse++;
3579	continue;
3580	}
3581	if (PL_regflags & PMf_EXTENDED) {
3582	if (isSPACE(*PL_regcomp_parse)) {
3583	PL_regcomp_parse++;
3584	continue;
3585	}
3586	else if (*PL_regcomp_parse == '#') {
3587	while (PL_regcomp_parse && PL_regcomp_parse != '\n')
3588	PL_regcomp_parse++;
3589	PL_regcomp_parse++;
3590	continue;
3591	}
3592	}
3593	return retval;
3594	}
3595	}
3596
3597	/*
3598	- reg_node - emit a node
3599	*/
3600	STATIC regnode * /* Location. */
3601	S_reg_node(pTHX_ U8 op)
3602	{
3603	dTHR;
3604	register regnode *ret;
3605	register regnode *ptr;
3606
3607	ret = PL_regcode;
3608	if (SIZE_ONLY) {
3609	SIZE_ALIGN(PL_regsize);
3610	PL_regsize += 1;
3611	return(ret);
3612	}
3613
3614	NODE_ALIGN_FILL(ret);
3615	ptr = ret;
3616	FILL_ADVANCE_NODE(ptr, op);
3617	PL_regcode = ptr;
3618
3619	return(ret);
3620	}
3621
3622	/*
3623	- reganode - emit a node with an argument
3624	*/
3625	STATIC regnode * /* Location. */
3626	S_reganode(pTHX_ U8 op, U32 arg)
3627	{
3628	dTHR;
3629	register regnode *ret;
3630	register regnode *ptr;
3631
3632	ret = PL_regcode;
3633	if (SIZE_ONLY) {
3634	SIZE_ALIGN(PL_regsize);
3635	PL_regsize += 2;
3636	return(ret);
3637	}
3638
3639	NODE_ALIGN_FILL(ret);
3640	ptr = ret;
3641	FILL_ADVANCE_NODE_ARG(ptr, op, arg);
3642	PL_regcode = ptr;
3643
3644	return(ret);
3645	}
3646
3647	/*
3648	- reguni - emit (if appropriate) a Unicode character
3649	*/
3650	STATIC void
3651	S_reguni(pTHX_ UV uv, char* s, I32* lenp)
3652	{
3653	dTHR;
3654	if (SIZE_ONLY) {
3655	U8 tmpbuf[UTF8_MAXLEN];
3656	*lenp = uv_to_utf8(tmpbuf, uv) - tmpbuf;
3657	}
3658	else
3659	lenp = uv_to_utf8((U8)s, uv) - (U8*)s;
3660
3661	}
3662
3663	/*
3664	- reginsert - insert an operator in front of already-emitted operand
3665	*
3666	* Means relocating the operand.
3667	*/
3668	STATIC void
3669	S_reginsert(pTHX_ U8 op, regnode *opnd)
3670	{
3671	dTHR;
3672	register regnode *src;
3673	register regnode *dst;
3674	register regnode *place;
3675	register int offset = regarglen[(U8)op];
3676
3677	/* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
3678
3679	if (SIZE_ONLY) {
3680	PL_regsize += NODE_STEP_REGNODE + offset;
3681	return;
3682	}
3683
3684	src = PL_regcode;
3685	PL_regcode += NODE_STEP_REGNODE + offset;
3686	dst = PL_regcode;
3687	while (src > opnd)
3688	StructCopy(--src, --dst, regnode);
3689
3690	place = opnd; /* Op node, where operand used to be. */
3691	src = NEXTOPER(place);
3692	FILL_ADVANCE_NODE(place, op);
3693	Zero(src, offset, regnode);
3694	}
3695
3696	/*
3697	- regtail - set the next-pointer at the end of a node chain of p to val.
3698	*/
3699	STATIC void
3700	S_regtail(pTHX_ regnode p, regnode val)
3701	{
3702	dTHR;
3703	register regnode *scan;
3704	register regnode *temp;
3705
3706	if (SIZE_ONLY)
3707	return;
3708
3709	/* Find last node. */
3710	scan = p;
3711	for (;;) {
3712	temp = regnext(scan);
3713	if (temp == NULL)
3714	break;
3715	scan = temp;
3716	}
3717
3718	if (reg_off_by_arg[OP(scan)]) {
3719	ARG_SET(scan, val - scan);
3720	}
3721	else {
3722	NEXT_OFF(scan) = val - scan;
3723	}
3724	}
3725
3726	/*
3727	- regoptail - regtail on operand of first argument; nop if operandless
3728	*/
3729	STATIC void
3730	S_regoptail(pTHX_ regnode p, regnode val)
3731	{
3732	dTHR;
3733	/* "Operandless" and "op != BRANCH" are synonymous in practice. */
3734	if (p == NULL \|\| SIZE_ONLY)
3735	return;
3736	if (PL_regkind[(U8)OP(p)] == BRANCH) {
3737	regtail(NEXTOPER(p), val);
3738	}
3739	else if ( PL_regkind[(U8)OP(p)] == BRANCHJ) {
3740	regtail(NEXTOPER(NEXTOPER(p)), val);
3741	}
3742	else
3743	return;
3744	}
3745
3746	/*
3747	- regcurly - a little FSA that accepts {\d+,?\d*}
3748	*/
3749	STATIC I32
3750	S_regcurly(pTHX_ register char *s)
3751	{
3752	if (*s++ != '{')
3753	return FALSE;
3754	if (!isDIGIT(*s))
3755	return FALSE;
3756	while (isDIGIT(*s))
3757	s++;
3758	if (*s == ',')
3759	s++;
3760	while (isDIGIT(*s))
3761	s++;
3762	if (*s != '}')
3763	return FALSE;
3764	return TRUE;
3765	}
3766
3767
3768	STATIC regnode *
3769	S_dumpuntil(pTHX_ regnode start, regnode node, regnode last, SV sv, I32 l)
3770	{
3771	#ifdef DEBUGGING
3772	register U8 op = EXACT; /* Arbitrary non-END op. */
3773	register regnode *next;
3774
3775	while (op != END && (!last \|\| node < last)) {
3776	/* While that wasn't END last time... */
3777
3778	NODE_ALIGN(node);
3779	op = OP(node);
3780	if (op == CLOSE)
3781	l--;
3782	next = regnext(node);
3783	/* Where, what. */
3784	if (OP(node) == OPTIMIZED)
3785	goto after_print;
3786	regprop(sv, node);
3787	PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
3788	(int)(2*l + 1), "", SvPVX(sv));
3789	if (next == NULL) /* Next ptr. */
3790	PerlIO_printf(Perl_debug_log, "(0)");
3791	else
3792	PerlIO_printf(Perl_debug_log, "(%"IVdf")", (IV)(next - start));
3793	(void)PerlIO_putc(Perl_debug_log, '\n');
3794	after_print:
3795	if (PL_regkind[(U8)op] == BRANCHJ) {
3796	register regnode *nnode = (OP(next) == LONGJMP
3797	? regnext(next)
3798	: next);
3799	if (last && nnode > last)
3800	nnode = last;
3801	node = dumpuntil(start, NEXTOPER(NEXTOPER(node)), nnode, sv, l + 1);
3802	}
3803	else if (PL_regkind[(U8)op] == BRANCH) {
3804	node = dumpuntil(start, NEXTOPER(node), next, sv, l + 1);
3805	}
3806	else if ( op == CURLY) { /* `next' might be very big: optimizer */
3807	node = dumpuntil(start, NEXTOPER(node) + EXTRA_STEP_2ARGS,
3808	NEXTOPER(node) + EXTRA_STEP_2ARGS + 1, sv, l + 1);
3809	}
3810	else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
3811	node = dumpuntil(start, NEXTOPER(node) + EXTRA_STEP_2ARGS,
3812	next, sv, l + 1);
3813	}
3814	else if ( op == PLUS \|\| op == STAR) {
3815	node = dumpuntil(start, NEXTOPER(node), NEXTOPER(node) + 1, sv, l + 1);
3816	}
3817	else if (op == ANYOF) {
3818	node = NEXTOPER(node);
3819	node += ANYOF_SKIP;
3820	}
3821	else if (PL_regkind[(U8)op] == EXACT) {
3822	/* Literal string, where present. */
3823	node += NODE_SZ_STR(node) - 1;
3824	node = NEXTOPER(node);
3825	}
3826	else {
3827	node = NEXTOPER(node);
3828	node += regarglen[(U8)op];
3829	}
3830	if (op == CURLYX \|\| op == OPEN)
3831	l++;
3832	else if (op == WHILEM)
3833	l--;
3834	}
3835	#endif /* DEBUGGING */
3836	return node;
3837	}
3838
3839	/*
3840	- regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
3841	*/
3842	void
3843	Perl_regdump(pTHX_ regexp *r)
3844	{
3845	#ifdef DEBUGGING
3846	dTHR;
3847	SV *sv = sv_newmortal();
3848
3849	(void)dumpuntil(r->program, r->program + 1, NULL, sv, 0);
3850
3851	/* Header fields of interest. */
3852	if (r->anchored_substr)
3853	PerlIO_printf(Perl_debug_log,
3854	"anchored `%s%.*s%s'%s at %"IVdf" ",
3855	PL_colors[0],
3856	(int)(SvCUR(r->anchored_substr) - (SvTAIL(r->anchored_substr)!=0)),
3857	SvPVX(r->anchored_substr),
3858	PL_colors[1],
3859	SvTAIL(r->anchored_substr) ? "$" : "",
3860	(IV)r->anchored_offset);
3861	if (r->float_substr)
3862	PerlIO_printf(Perl_debug_log,
3863	"floating `%s%.*s%s'%s at %"IVdf"..%"UVuf" ",
3864	PL_colors[0],
3865	(int)(SvCUR(r->float_substr) - (SvTAIL(r->float_substr)!=0)),
3866	SvPVX(r->float_substr),
3867	PL_colors[1],
3868	SvTAIL(r->float_substr) ? "$" : "",
3869	(IV)r->float_min_offset, (UV)r->float_max_offset);
3870	if (r->check_substr)
3871	PerlIO_printf(Perl_debug_log,
3872	r->check_substr == r->float_substr
3873	? "(checking floating" : "(checking anchored");
3874	if (r->reganch & ROPT_NOSCAN)
3875	PerlIO_printf(Perl_debug_log, " noscan");
3876	if (r->reganch & ROPT_CHECK_ALL)
3877	PerlIO_printf(Perl_debug_log, " isall");
3878	if (r->check_substr)
3879	PerlIO_printf(Perl_debug_log, ") ");
3880
3881	if (r->regstclass) {
3882	regprop(sv, r->regstclass);
3883	PerlIO_printf(Perl_debug_log, "stclass `%s' ", SvPVX(sv));
3884	}
3885	if (r->reganch & ROPT_ANCH) {
3886	PerlIO_printf(Perl_debug_log, "anchored");
3887	if (r->reganch & ROPT_ANCH_BOL)
3888	PerlIO_printf(Perl_debug_log, "(BOL)");
3889	if (r->reganch & ROPT_ANCH_MBOL)
3890	PerlIO_printf(Perl_debug_log, "(MBOL)");
3891	if (r->reganch & ROPT_ANCH_SBOL)
3892	PerlIO_printf(Perl_debug_log, "(SBOL)");
3893	if (r->reganch & ROPT_ANCH_GPOS)
3894	PerlIO_printf(Perl_debug_log, "(GPOS)");
3895	PerlIO_putc(Perl_debug_log, ' ');
3896	}
3897	if (r->reganch & ROPT_GPOS_SEEN)
3898	PerlIO_printf(Perl_debug_log, "GPOS ");
3899	if (r->reganch & ROPT_SKIP)
3900	PerlIO_printf(Perl_debug_log, "plus ");
3901	if (r->reganch & ROPT_IMPLICIT)
3902	PerlIO_printf(Perl_debug_log, "implicit ");
3903	PerlIO_printf(Perl_debug_log, "minlen %ld ", (long) r->minlen);
3904	if (r->reganch & ROPT_EVAL_SEEN)
3905	PerlIO_printf(Perl_debug_log, "with eval ");
3906	PerlIO_printf(Perl_debug_log, "\n");
3907	#endif /* DEBUGGING */
3908	}
3909
3910	STATIC void
3911	S_put_byte(pTHX_ SV *sv, int c)
3912	{
3913	if (c <= ' ' \|\| c == 127 \|\| c == 255)
3914	Perl_sv_catpvf(aTHX_ sv, "\\%o", c);
3915	else if (c == '-' \|\| c == ']' \|\| c == '\\' \|\| c == '^')
3916	Perl_sv_catpvf(aTHX_ sv, "\\%c", c);
3917	else
3918	Perl_sv_catpvf(aTHX_ sv, "%c", c);
3919	}
3920
3921	/*
3922	- regprop - printable representation of opcode
3923	*/
3924	void
3925	Perl_regprop(pTHX_ SV sv, regnode o)
3926	{
3927	#ifdef DEBUGGING
3928	dTHR;
3929	register int k;
3930
3931	sv_setpvn(sv, "", 0);
3932	if (OP(o) >= reg_num) /* regnode.type is unsigned */
3933	FAIL("corrupted regexp opcode");
3934	sv_catpv(sv, (char)reg_name[OP(o)]); / Take off const! */
3935
3936	k = PL_regkind[(U8)OP(o)];
3937
3938	if (k == EXACT)
3939	Perl_sv_catpvf(aTHX_ sv, " <%s%.*s%s>", PL_colors[0],
3940	STR_LEN(o), STRING(o), PL_colors[1]);
3941	else if (k == CURLY) {
3942	if (OP(o) == CURLYM \|\| OP(o) == CURLYN)
3943	Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
3944	Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
3945	}
3946	else if (k == WHILEM && o->flags) /* Ordinal/of */
3947	Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
3948	else if (k == REF \|\| k == OPEN \|\| k == CLOSE \|\| k == GROUPP )
3949	Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o)); /* Parenth number */
3950	else if (k == LOGICAL)
3951	Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* 2: embedded, otherwise 1 */
3952	else if (k == ANYOF) {
3953	int i, rangestart = -1;
3954	const char * const out[] = { /* Should be syncronized with
3955	a table in regcomp.h */
3956	"\\w",
3957	"\\W",
3958	"\\s",
3959	"\\S",
3960	"\\d",
3961	"\\D",
3962	"[:alnum:]",
3963	"[:^alnum:]",
3964	"[:alpha:]",
3965	"[:^alpha:]",
3966	"[:ascii:]",
3967	"[:^ascii:]",
3968	"[:ctrl:]",
3969	"[:^ctrl:]",
3970	"[:graph:]",
3971	"[:^graph:]",
3972	"[:lower:]",
3973	"[:^lower:]",
3974	"[:print:]",
3975	"[:^print:]",
3976	"[:punct:]",
3977	"[:^punct:]",
3978	"[:upper:]",
3979	"[:!upper:]",
3980	"[:xdigit:]",
3981	"[:^xdigit:]"
3982	};
3983
3984	if (o->flags & ANYOF_LOCALE)
3985	sv_catpv(sv, "{loc}");
3986	if (o->flags & ANYOF_FOLD)
3987	sv_catpv(sv, "{i}");
3988	Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
3989	if (o->flags & ANYOF_INVERT)
3990	sv_catpv(sv, "^");
3991	for (i = 0; i <= 256; i++) {
3992	if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
3993	if (rangestart == -1)
3994	rangestart = i;
3995	} else if (rangestart != -1) {
3996	if (i <= rangestart + 3)
3997	for (; rangestart < i; rangestart++)
3998	put_byte(sv, rangestart);
3999	else {
4000	put_byte(sv, rangestart);
4001	sv_catpv(sv, "-");
4002	put_byte(sv, i - 1);
4003	}
4004	rangestart = -1;
4005	}
4006	}
4007	if (o->flags & ANYOF_CLASS)
4008	for (i = 0; i < sizeof(out)/sizeof(char*); i++)
4009	if (ANYOF_CLASS_TEST(o,i))
4010	sv_catpv(sv, out[i]);
4011	Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
4012	}
4013	else if (k == BRANCHJ && (OP(o) == UNLESSM \|\| OP(o) == IFMATCH))
4014	Perl_sv_catpvf(aTHX_ sv, "[-%d]", o->flags);
4015	#endif /* DEBUGGING */
4016	}
4017
4018	SV *
4019	Perl_re_intuit_string(pTHX_ regexp *prog)
4020	{ /* Assume that RE_INTUIT is set */
4021	DEBUG_r(
4022	{ STRLEN n_a;
4023	char *s = SvPV(prog->check_substr,n_a);
4024
4025	if (!PL_colorset) reginitcolors();
4026	PerlIO_printf(Perl_debug_log,
4027	"%sUsing REx substr:%s `%s%.60s%s%s'\n",
4028	PL_colors[4],PL_colors[5],PL_colors[0],
4029	s,
4030	PL_colors[1],
4031	(strlen(s) > 60 ? "..." : ""));
4032	} );
4033
4034	return prog->check_substr;
4035	}
4036
4037	void
4038	Perl_pregfree(pTHX_ struct regexp *r)
4039	{
4040	dTHR;
4041	DEBUG_r(if (!PL_colorset) reginitcolors());
4042
4043	if (!r \|\| (--r->refcnt > 0))
4044	return;
4045	DEBUG_r(PerlIO_printf(Perl_debug_log,
4046	"%sFreeing REx:%s `%s%.60s%s%s'\n",
4047	PL_colors[4],PL_colors[5],PL_colors[0],
4048	r->precomp,
4049	PL_colors[1],
4050	(strlen(r->precomp) > 60 ? "..." : "")));
4051
4052	if (r->precomp)
4053	Safefree(r->precomp);
4054	if (RX_MATCH_COPIED(r))
4055	Safefree(r->subbeg);
4056	if (r->substrs) {
4057	if (r->anchored_substr)
4058	SvREFCNT_dec(r->anchored_substr);
4059	if (r->float_substr)
4060	SvREFCNT_dec(r->float_substr);
4061	Safefree(r->substrs);
4062	}
4063	if (r->data) {
4064	int n = r->data->count;
4065	AV* new_comppad = NULL;
4066	AV* old_comppad;
4067	SV** old_curpad;
4068
4069	while (--n >= 0) {
4070	switch (r->data->what[n]) {
4071	case 's':
4072	SvREFCNT_dec((SV*)r->data->data[n]);
4073	break;
4074	case 'f':
4075	Safefree(r->data->data[n]);
4076	break;
4077	case 'p':
4078	new_comppad = (AV*)r->data->data[n];
4079	break;
4080	case 'o':
4081	if (new_comppad == NULL)
4082	Perl_croak(aTHX_ "panic: pregfree comppad");
4083	old_comppad = PL_comppad;
4084	old_curpad = PL_curpad;
4085	PL_comppad = new_comppad;
4086	PL_curpad = AvARRAY(new_comppad);
4087	op_free((OP_4tree*)r->data->data[n]);
4088	PL_comppad = old_comppad;
4089	PL_curpad = old_curpad;
4090	SvREFCNT_dec((SV*)new_comppad);
4091	new_comppad = NULL;
4092	break;
4093	case 'n':
4094	break;
4095	default:
4096	FAIL2("panic: regfree data code '%c'", r->data->what[n]);
4097	}
4098	}
4099	Safefree(r->data->what);
4100	Safefree(r->data);
4101	}
4102	Safefree(r->startp);
4103	Safefree(r->endp);
4104	Safefree(r);
4105	}
4106
4107	/*
4108	- regnext - dig the "next" pointer out of a node
4109	*
4110	* [Note, when REGALIGN is defined there are two places in regmatch()
4111	* that bypass this code for speed.]
4112	*/
4113	regnode *
4114	Perl_regnext(pTHX_ register regnode *p)
4115	{
4116	dTHR;
4117	register I32 offset;
4118
4119	if (p == &PL_regdummy)
4120	return(NULL);
4121
4122	offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
4123	if (offset == 0)
4124	return(NULL);
4125
4126	return(p+offset);
4127	}
4128
4129	STATIC void
4130	S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
4131	{
4132	va_list args;
4133	STRLEN l1 = strlen(pat1);
4134	STRLEN l2 = strlen(pat2);
4135	char buf[512];
4136	SV *msv;
4137	char *message;
4138
4139	if (l1 > 510)
4140	l1 = 510;
4141	if (l1 + l2 > 510)
4142	l2 = 510 - l1;
4143	Copy(pat1, buf, l1 , char);
4144	Copy(pat2, buf + l1, l2 , char);
4145	buf[l1 + l2] = '\n';
4146	buf[l1 + l2 + 1] = '\0';
4147	#ifdef I_STDARG
4148	/* ANSI variant takes additional second argument */
4149	va_start(args, pat2);
4150	#else
4151	va_start(args);
4152	#endif
4153	msv = vmess(buf, &args);
4154	va_end(args);
4155	message = SvPV(msv,l1);
4156	if (l1 > 512)
4157	l1 = 512;
4158	Copy(message, buf, l1 , char);
4159	buf[l1] = '\0'; /* Overwrite \n */
4160	Perl_croak(aTHX_ "%s", buf);
4161	}
4162
4163	/* XXX Here's a total kludge. But we need to re-enter for swash routines. */
4164
4165	void
4166	Perl_save_re_context(pTHX)
4167	{
4168	dTHR;
4169	SAVEPPTR(PL_bostr);
4170	SAVEPPTR(PL_regprecomp); /* uncompiled string. */
4171	SAVEI32(PL_regnpar); /* () count. */
4172	SAVEI32(PL_regsize); /* Code size. */
4173	SAVEI16(PL_regflags); /* are we folding, multilining? */
4174	SAVEPPTR(PL_reginput); /* String-input pointer. */
4175	SAVEPPTR(PL_regbol); /* Beginning of input, for ^ check. */
4176	SAVEPPTR(PL_regeol); /* End of input, for $ check. */
4177	SAVEVPTR(PL_regstartp); /* Pointer to startp array. */
4178	SAVEVPTR(PL_regendp); /* Ditto for endp. */
4179	SAVEVPTR(PL_reglastparen); /* Similarly for lastparen. */
4180	SAVEPPTR(PL_regtill); /* How far we are required to go. */
4181	SAVEI8(PL_regprev); /* char before regbol, \n if none */
4182	SAVEVPTR(PL_reg_start_tmp); /* from regexec.c */
4183	PL_reg_start_tmp = 0;
4184	SAVEFREEPV(PL_reg_start_tmp);
4185	SAVEI32(PL_reg_start_tmpl); /* from regexec.c */
4186	PL_reg_start_tmpl = 0;
4187	SAVEVPTR(PL_regdata);
4188	SAVEI32(PL_reg_flags); /* from regexec.c */
4189	SAVEI32(PL_reg_eval_set); /* from regexec.c */
4190	SAVEI32(PL_regnarrate); /* from regexec.c */
4191	SAVEVPTR(PL_regprogram); /* from regexec.c */
4192	SAVEINT(PL_regindent); /* from regexec.c */
4193	SAVEVPTR(PL_regcc); /* from regexec.c */
4194	SAVEVPTR(PL_curcop);
4195	SAVEVPTR(PL_regcomp_rx); /* from regcomp.c */
4196	SAVEI32(PL_regseen); /* from regcomp.c */
4197	SAVEI32(PL_regsawback); /* Did we see \1, ...? */
4198	SAVEI32(PL_regnaughty); /* How bad is this pattern? */
4199	SAVEVPTR(PL_regcode); /* Code-emit pointer; &regdummy = don't */
4200	SAVEPPTR(PL_regxend); /* End of input for compile */
4201	SAVEPPTR(PL_regcomp_parse); /* Input-scan pointer. */
4202	SAVEVPTR(PL_reg_call_cc); /* from regexec.c */
4203	SAVEVPTR(PL_reg_re); /* from regexec.c */
4204	SAVEPPTR(PL_reg_ganch); /* from regexec.c */
4205	SAVESPTR(PL_reg_sv); /* from regexec.c */
4206	SAVEVPTR(PL_reg_magic); /* from regexec.c */
4207	SAVEI32(PL_reg_oldpos); /* from regexec.c */
4208	SAVEVPTR(PL_reg_oldcurpm); /* from regexec.c */
4209	SAVEVPTR(PL_reg_curpm); /* from regexec.c */
4210	#ifdef DEBUGGING
4211	SAVEPPTR(PL_reg_starttry); /* from regexec.c */
4212	#endif
4213	}
4214
4215	#ifdef PERL_OBJECT
4216	#include "XSUB.h"
4217	#undef this
4218	#define this pPerl
4219	#endif
4220
4221	static void
4222	clear_re(pTHXo_ void *r)
4223	{
4224	ReREFCNT_dec((regexp *)r);
4225	}
4226

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

Download in other formats: