Context Navigation

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

Visit:

Revision 14545, 94.9 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	/* regexec.c
2	*/
3
4	/*
5	* "One Ring to rule them all, One Ring to find them..."
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_regexec_flags my_regexec
36	# define Perl_regdump my_regdump
37	# define Perl_regprop my_regprop
38	# define Perl_re_intuit_start my_re_intuit_start
39	/* These symbols are masked to allow static link. */
40	# define Perl_pregexec my_pregexec
41	# define Perl_reginitcolors my_reginitcolors
42
43	# define PERL_NO_GET_CONTEXT
44	#endif
45
46	/SUPPRESS 112/
47	/*
48	* pregcomp and pregexec -- regsub and regerror are not used in perl
49	*
50	* Copyright (c) 1986 by University of Toronto.
51	* Written by Henry Spencer. Not derived from licensed software.
52	*
53	* Permission is granted to anyone to use this software for any
54	* purpose on any computer system, and to redistribute it freely,
55	* subject to the following restrictions:
56	*
57	* 1. The author is not responsible for the consequences of use of
58	* this software, no matter how awful, even if they arise
59	* from defects in it.
60	*
61	* 2. The origin of this software must not be misrepresented, either
62	* by explicit claim or by omission.
63	*
64	* 3. Altered versions must be plainly marked as such, and must not
65	* be misrepresented as being the original software.
66	*
67	**** Alterations to Henry's code are...
68	****
69	**** Copyright (c) 1991-2000, Larry Wall
70	****
71	**** You may distribute under the terms of either the GNU General Public
72	**** License or the Artistic License, as specified in the README file.
73	*
74	* Beware that some of this code is subtly aware of the way operator
75	* precedence is structured in regular expressions. Serious changes in
76	* regular-expression syntax might require a total rethink.
77	*/
78	#include "EXTERN.h"
79	#define PERL_IN_REGEXEC_C
80	#include "perl.h"
81
82	#ifdef PERL_IN_XSUB_RE
83	# if defined(PERL_CAPI) \|\| defined(PERL_OBJECT)
84	# include "XSUB.h"
85	# endif
86	#endif
87
88	#include "regcomp.h"
89
90	#define RF_tainted 1 /* tainted information used? */
91	#define RF_warned 2 /* warned about big count? */
92	#define RF_evaled 4 /* Did an EVAL with setting? */
93	#define RF_utf8 8 /* String contains multibyte chars? */
94
95	#define UTF (PL_reg_flags & RF_utf8)
96
97	#define RS_init 1 /* eval environment created */
98	#define RS_set 2 /* replsv value is set */
99
100	#ifndef STATIC
101	#define STATIC static
102	#endif
103
104	/*
105	* Forwards.
106	*/
107
108	#define REGINCLASS(p,c) (ANYOF_FLAGS(p) ? reginclass(p,c) : ANYOF_BITMAP_TEST(p,c))
109	#define REGINCLASSUTF8(f,p) (ARG1(f) ? reginclassutf8(f,p) : swash_fetch((SV*)PL_regdata->data[ARG2(f)],p))
110
111	#define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
112	#define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
113
114	#define reghop_c(pos,off) ((char)reghop((U8)pos, off))
115	#define reghopmaybe_c(pos,off) ((char)reghopmaybe((U8)pos, off))
116	#define HOP(pos,off) (UTF ? reghop((U8)pos, off) : (U8)(pos + off))
117	#define HOPMAYBE(pos,off) (UTF ? reghopmaybe((U8)pos, off) : (U8)(pos + off))
118	#define HOPc(pos,off) ((char*)HOP(pos,off))
119	#define HOPMAYBEc(pos,off) ((char*)HOPMAYBE(pos,off))
120
121	static void restore_pos(pTHXo_ void *arg);
122
123
124	STATIC CHECKPOINT
125	S_regcppush(pTHX_ I32 parenfloor)
126	{
127	dTHR;
128	int retval = PL_savestack_ix;
129	int i = (PL_regsize - parenfloor) * 4;
130	int p;
131
132	SSCHECK(i + 5);
133	for (p = PL_regsize; p > parenfloor; p--) {
134	SSPUSHINT(PL_regendp[p]);
135	SSPUSHINT(PL_regstartp[p]);
136	SSPUSHPTR(PL_reg_start_tmp[p]);
137	SSPUSHINT(p);
138	}
139	SSPUSHINT(PL_regsize);
140	SSPUSHINT(*PL_reglastparen);
141	SSPUSHPTR(PL_reginput);
142	SSPUSHINT(i + 3);
143	SSPUSHINT(SAVEt_REGCONTEXT);
144	return retval;
145	}
146
147	/* These are needed since we do not localize EVAL nodes: */
148	# define REGCP_SET DEBUG_r(PerlIO_printf(Perl_debug_log, \
149	" Setting an EVAL scope, savestack=%"IVdf"\n", \
150	(IV)PL_savestack_ix)); lastcp = PL_savestack_ix
151
152	# define REGCP_UNWIND DEBUG_r(lastcp != PL_savestack_ix ? \
153	PerlIO_printf(Perl_debug_log, \
154	" Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \
155	(IV)lastcp, (IV)PL_savestack_ix) : 0); regcpblow(lastcp)
156
157	STATIC char *
158	S_regcppop(pTHX)
159	{
160	dTHR;
161	I32 i = SSPOPINT;
162	U32 paren = 0;
163	char *input;
164	I32 tmps;
165	assert(i == SAVEt_REGCONTEXT);
166	i = SSPOPINT;
167	input = (char *) SSPOPPTR;
168	*PL_reglastparen = SSPOPINT;
169	PL_regsize = SSPOPINT;
170	for (i -= 3; i > 0; i -= 4) {
171	paren = (U32)SSPOPINT;
172	PL_reg_start_tmp[paren] = (char *) SSPOPPTR;
173	PL_regstartp[paren] = SSPOPINT;
174	tmps = SSPOPINT;
175	if (paren <= *PL_reglastparen)
176	PL_regendp[paren] = tmps;
177	DEBUG_r(
178	PerlIO_printf(Perl_debug_log,
179	" restoring \\%"UVuf" to %"IVdf"(%"IVdf")..%"IVdf"%s\n",
180	(UV)paren, (IV)PL_regstartp[paren],
181	(IV)(PL_reg_start_tmp[paren] - PL_bostr),
182	(IV)PL_regendp[paren],
183	(paren > *PL_reglastparen ? "(no)" : ""));
184	);
185	}
186	DEBUG_r(
187	if (*PL_reglastparen + 1 <= PL_regnpar) {
188	PerlIO_printf(Perl_debug_log,
189	" restoring \\%"IVdf"..\\%"IVdf" to undef\n",
190	(IV)(*PL_reglastparen + 1), (IV)PL_regnpar);
191	}
192	);
193	for (paren = *PL_reglastparen + 1; paren <= PL_regnpar; paren++) {
194	if (paren > PL_regsize)
195	PL_regstartp[paren] = -1;
196	PL_regendp[paren] = -1;
197	}
198	return input;
199	}
200
201	STATIC char *
202	S_regcp_set_to(pTHX_ I32 ss)
203	{
204	dTHR;
205	I32 tmp = PL_savestack_ix;
206
207	PL_savestack_ix = ss;
208	regcppop();
209	PL_savestack_ix = tmp;
210	return Nullch;
211	}
212
213	typedef struct re_cc_state
214	{
215	I32 ss;
216	regnode *node;
217	struct re_cc_state *prev;
218	CURCUR *cc;
219	regexp *re;
220	} re_cc_state;
221
222	#define regcpblow(cp) LEAVE_SCOPE(cp)
223
224	/*
225	* pregexec and friends
226	*/
227
228	/*
229	- pregexec - match a regexp against a string
230	*/
231	I32
232	Perl_pregexec(pTHX_ register regexp prog, char stringarg, register char *strend,
233	char strbeg, I32 minend, SV screamer, U32 nosave)
234	/* strend: pointer to null at end of string */
235	/* strbeg: real beginning of string */
236	/* minend: end of match must be >=minend after stringarg. */
237	/* nosave: For optimizations. */
238	{
239	return
240	regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL,
241	nosave ? 0 : REXEC_COPY_STR);
242	}
243
244	STATIC void
245	S_cache_re(pTHX_ regexp *prog)
246	{
247	dTHR;
248	PL_regprecomp = prog->precomp; /* Needed for FAIL. */
249	#ifdef DEBUGGING
250	PL_regprogram = prog->program;
251	#endif
252	PL_regnpar = prog->nparens;
253	PL_regdata = prog->data;
254	PL_reg_re = prog;
255	}
256
257	/*
258	* Need to implement the following flags for reg_anch:
259	*
260	* USE_INTUIT_NOML - Useful to call re_intuit_start() first
261	* USE_INTUIT_ML
262	* INTUIT_AUTORITATIVE_NOML - Can trust a positive answer
263	* INTUIT_AUTORITATIVE_ML
264	* INTUIT_ONCE_NOML - Intuit can match in one location only.
265	* INTUIT_ONCE_ML
266	*
267	* Another flag for this function: SECOND_TIME (so that float substrs
268	* with giant delta may be not rechecked).
269	*/
270
271	/* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */
272
273	/* If SCREAM, then SvPVX(sv) should be compatible with strpos and strend.
274	Otherwise, only SvCUR(sv) is used to get strbeg. */
275
276	/* XXXX We assume that strpos is strbeg unless sv. */
277
278	/* XXXX Some places assume that there is a fixed substring.
279	An update may be needed if optimizer marks as "INTUITable"
280	RExen without fixed substrings. Similarly, it is assumed that
281	lengths of all the strings are no more than minlen, thus they
282	cannot come from lookahead.
283	(Or minlen should take into account lookahead.) */
284
285	/* A failure to find a constant substring means that there is no need to make
286	an expensive call to REx engine, thus we celebrate a failure. Similarly,
287	finding a substring too deep into the string means that less calls to
288	regtry() should be needed.
289
290	REx compiler's optimizer found 4 possible hints:
291	a) Anchored substring;
292	b) Fixed substring;
293	c) Whether we are anchored (beginning-of-line or \G);
294	d) First node (of those at offset 0) which may distingush positions;
295	We use a)b)d) and multiline-part of c), and try to find a position in the
296	string which does not contradict any of them.
297	*/
298
299	/* Most of decisions we do here should have been done at compile time.
300	The nodes of the REx which we used for the search should have been
301	deleted from the finite automaton. */
302
303	char *
304	Perl_re_intuit_start(pTHX_ regexp prog, SV sv, char *strpos,
305	char strend, U32 flags, re_scream_pos_data data)
306	{
307	register I32 start_shift;
308	/* Should be nonnegative! */
309	register I32 end_shift;
310	register char *s;
311	register SV *check;
312	char *t;
313	I32 ml_anch;
314	char *tmp;
315	register char other_last = Nullch; / other substr checked before this */
316	char check_at; / check substr found at this pos */
317	#ifdef DEBUGGING
318	char *i_strpos = strpos;
319	#endif
320
321	DEBUG_r( if (!PL_colorset) reginitcolors() );
322	DEBUG_r(PerlIO_printf(Perl_debug_log,
323	"%sGuessing start of match, REx%s `%s%.60s%s%s' against `%s%.*s%s%s'...\n",
324	PL_colors[4],PL_colors[5],PL_colors[0],
325	prog->precomp,
326	PL_colors[1],
327	(strlen(prog->precomp) > 60 ? "..." : ""),
328	PL_colors[0],
329	(int)(strend - strpos > 60 ? 60 : strend - strpos),
330	strpos, PL_colors[1],
331	(strend - strpos > 60 ? "..." : ""))
332	);
333
334	if (prog->minlen > strend - strpos) {
335	DEBUG_r(PerlIO_printf(Perl_debug_log, "String too short...\n"));
336	goto fail;
337	}
338	check = prog->check_substr;
339	if (prog->reganch & ROPT_ANCH) { /* Match at beg-of-str or after \n */
340	ml_anch = !( (prog->reganch & ROPT_ANCH_SINGLE)
341	\|\| ( (prog->reganch & ROPT_ANCH_BOL)
342	&& !PL_multiline ) ); /* Check after \n? */
343
344	if ((prog->check_offset_min == prog->check_offset_max) && !ml_anch) {
345	/* Substring at constant offset from beg-of-str... */
346	I32 slen;
347
348	if ( !(prog->reganch & ROPT_ANCH_GPOS) /* Checked by the caller */
349	&& (sv && (strpos + SvCUR(sv) != strend)) ) {
350	DEBUG_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
351	goto fail;
352	}
353	PL_regeol = strend; /* Used in HOP() */
354	s = HOPc(strpos, prog->check_offset_min);
355	if (SvTAIL(check)) {
356	slen = SvCUR(check); /* >= 1 */
357
358	if ( strend - s > slen \|\| strend - s < slen - 1
359	\|\| (strend - s == slen && strend[-1] != '\n')) {
360	DEBUG_r(PerlIO_printf(Perl_debug_log, "String too long...\n"));
361	goto fail_finish;
362	}
363	/* Now should match s[0..slen-2] */
364	slen--;
365	if (slen && (SvPVX(check) != s
366	\|\| (slen > 1
367	&& memNE(SvPVX(check), s, slen)))) {
368	report_neq:
369	DEBUG_r(PerlIO_printf(Perl_debug_log, "String not equal...\n"));
370	goto fail_finish;
371	}
372	}
373	else if (SvPVX(check) != s
374	\|\| ((slen = SvCUR(check)) > 1
375	&& memNE(SvPVX(check), s, slen)))
376	goto report_neq;
377	goto success_at_start;
378	}
379	/* Match is anchored, but substr is not anchored wrt beg-of-str. */
380	s = strpos;
381	start_shift = prog->check_offset_min; /* okay to underestimate on CC */
382	end_shift = prog->minlen - start_shift -
383	CHR_SVLEN(check) + (SvTAIL(check) != 0);
384	if (!ml_anch) {
385	I32 end = prog->check_offset_max + CHR_SVLEN(check)
386	- (SvTAIL(check) != 0);
387	I32 eshift = strend - s - end;
388
389	if (end_shift < eshift)
390	end_shift = eshift;
391	}
392	}
393	else { /* Can match at random position */
394	ml_anch = 0;
395	s = strpos;
396	start_shift = prog->check_offset_min; /* okay to underestimate on CC */
397	/* Should be nonnegative! */
398	end_shift = prog->minlen - start_shift -
399	CHR_SVLEN(check) + (SvTAIL(check) != 0);
400	}
401
402	#ifdef DEBUGGING /* 7/99: reports of failure (with the older version) */
403	if (end_shift < 0)
404	Perl_croak(aTHX_ "panic: end_shift");
405	#endif
406
407	restart:
408	/* Find a possible match in the region s..strend by looking for
409	the "check" substring in the region corrected by start/end_shift. */
410	if (flags & REXEC_SCREAM) {
411	char strbeg = SvPVX(sv); / XXXX Assume PV_force() on SCREAM! */
412	I32 p = -1; /* Internal iterator of scream. */
413	I32 *pp = data ? data->scream_pos : &p;
414
415	if (PL_screamfirst[BmRARE(check)] >= 0
416	\|\| ( BmRARE(check) == '\n'
417	&& (BmPREVIOUS(check) == SvCUR(check) - 1)
418	&& SvTAIL(check) ))
419	s = screaminstr(sv, check,
420	start_shift + (s - strbeg), end_shift, pp, 0);
421	else
422	goto fail_finish;
423	if (data)
424	*data->scream_olds = s;
425	}
426	else
427	s = fbm_instr((unsigned char*)s + start_shift,
428	(unsigned char*)strend - end_shift,
429	check, PL_multiline ? FBMrf_MULTILINE : 0);
430
431	/* Update the count-of-usability, remove useless subpatterns,
432	unshift s. */
433
434	DEBUG_r(PerlIO_printf(Perl_debug_log, "%s %s substr `%s%.*s%s'%s%s",
435	(s ? "Found" : "Did not find"),
436	((check == prog->anchored_substr) ? "anchored" : "floating"),
437	PL_colors[0],
438	(int)(SvCUR(check) - (SvTAIL(check)!=0)),
439	SvPVX(check),
440	PL_colors[1], (SvTAIL(check) ? "$" : ""),
441	(s ? " at offset " : "...\n") ) );
442
443	if (!s)
444	goto fail_finish;
445
446	check_at = s;
447
448	/* Finish the diagnostic message */
449	DEBUG_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) );
450
451	/* Got a candidate. Check MBOL anchoring, and the other substr.
452	Start with the other substr.
453	XXXX no SCREAM optimization yet - and a very coarse implementation
454	XXXX /ttx+/ results in anchored=`ttx', floating=`x'. floating will
455	always match. Probably should be marked during compile...
456	Probably it is right to do no SCREAM here...
457	*/
458
459	if (prog->float_substr && prog->anchored_substr) {
460	/* Take into account the "other" substring. */
461	/* XXXX May be hopelessly wrong for UTF... */
462	if (!other_last)
463	other_last = strpos;
464	if (check == prog->float_substr) {
465	do_other_anchored:
466	{
467	char last = s - start_shift, last1, *last2;
468	char *s1 = s;
469
470	tmp = PL_bostr;
471	t = s - prog->check_offset_max;
472	if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */
473	&& (!(prog->reganch & ROPT_UTF8)
474	\|\| (PL_bostr = strpos, /* Used in regcopmaybe() */
475	(t = reghopmaybe_c(s, -(prog->check_offset_max)))
476	&& t > strpos)))
477	/* EMPTY */;
478	else
479	t = strpos;
480	t += prog->anchored_offset;
481	if (t < other_last) /* These positions already checked */
482	t = other_last;
483	PL_bostr = tmp;
484	last2 = last1 = strend - prog->minlen;
485	if (last < last1)
486	last1 = last;
487	/* XXXX It is not documented what units _offsets are in. Assume bytes. /
488	/* On end-of-str: see comment below. */
489	s = fbm_instr((unsigned char*)t,
490	(unsigned char*)last1 + prog->anchored_offset
491	+ SvCUR(prog->anchored_substr)
492	- (SvTAIL(prog->anchored_substr)!=0),
493	prog->anchored_substr, PL_multiline ? FBMrf_MULTILINE : 0);
494	DEBUG_r(PerlIO_printf(Perl_debug_log, "%s anchored substr `%s%.*s%s'%s",
495	(s ? "Found" : "Contradicts"),
496	PL_colors[0],
497	(int)(SvCUR(prog->anchored_substr)
498	- (SvTAIL(prog->anchored_substr)!=0)),
499	SvPVX(prog->anchored_substr),
500	PL_colors[1], (SvTAIL(prog->anchored_substr) ? "$" : "")));
501	if (!s) {
502	if (last1 >= last2) {
503	DEBUG_r(PerlIO_printf(Perl_debug_log,
504	", giving up...\n"));
505	goto fail_finish;
506	}
507	DEBUG_r(PerlIO_printf(Perl_debug_log,
508	", trying floating at offset %ld...\n",
509	(long)(s1 + 1 - i_strpos)));
510	PL_regeol = strend; /* Used in HOP() */
511	other_last = last1 + prog->anchored_offset + 1;
512	s = HOPc(last, 1);
513	goto restart;
514	}
515	else {
516	DEBUG_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
517	(long)(s - i_strpos)));
518	t = s - prog->anchored_offset;
519	other_last = s + 1;
520	s = s1;
521	if (t == strpos)
522	goto try_at_start;
523	goto try_at_offset;
524	}
525	}
526	}
527	else { /* Take into account the floating substring. */
528	char last, last1;
529	char *s1 = s;
530
531	t = s - start_shift;
532	last1 = last = strend - prog->minlen + prog->float_min_offset;
533	if (last - t > prog->float_max_offset)
534	last = t + prog->float_max_offset;
535	s = t + prog->float_min_offset;
536	if (s < other_last)
537	s = other_last;
538	/* XXXX It is not documented what units _offsets are in. Assume bytes. /
539	/* fbm_instr() takes into account exact value of end-of-str
540	if the check is SvTAIL(ed). Since false positives are OK,
541	and end-of-str is not later than strend we are OK. */
542	s = fbm_instr((unsigned char*)s,
543	(unsigned char*)last + SvCUR(prog->float_substr)
544	- (SvTAIL(prog->float_substr)!=0),
545	prog->float_substr, PL_multiline ? FBMrf_MULTILINE : 0);
546	DEBUG_r(PerlIO_printf(Perl_debug_log, "%s floating substr `%s%.*s%s'%s",
547	(s ? "Found" : "Contradicts"),
548	PL_colors[0],
549	(int)(SvCUR(prog->float_substr)
550	- (SvTAIL(prog->float_substr)!=0)),
551	SvPVX(prog->float_substr),
552	PL_colors[1], (SvTAIL(prog->float_substr) ? "$" : "")));
553	if (!s) {
554	if (last1 == last) {
555	DEBUG_r(PerlIO_printf(Perl_debug_log,
556	", giving up...\n"));
557	goto fail_finish;
558	}
559	DEBUG_r(PerlIO_printf(Perl_debug_log,
560	", trying anchored starting at offset %ld...\n",
561	(long)(s1 + 1 - i_strpos)));
562	other_last = last + 1;
563	PL_regeol = strend; /* Used in HOP() */
564	s = HOPc(t, 1);
565	goto restart;
566	}
567	else {
568	DEBUG_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
569	(long)(s - i_strpos)));
570	other_last = s + 1;
571	s = s1;
572	if (t == strpos)
573	goto try_at_start;
574	goto try_at_offset;
575	}
576	}
577	}
578
579	t = s - prog->check_offset_max;
580	tmp = PL_bostr;
581	if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */
582	&& (!(prog->reganch & ROPT_UTF8)
583	\|\| (PL_bostr = strpos, /* Used in regcopmaybe() */
584	((t = reghopmaybe_c(s, -(prog->check_offset_max)))
585	&& t > strpos)))) {
586	PL_bostr = tmp;
587	/* Fixed substring is found far enough so that the match
588	cannot start at strpos. */
589	try_at_offset:
590	if (ml_anch && t[-1] != '\n') {
591	/* Eventually fbm_*() should handle this, but often
592	anchored_offset is not 0, so this check will not be wasted. */
593	/* XXXX In the code below we prefer to look for "^" even in
594	presence of anchored substrings. And we search even
595	beyond the found float position. These pessimizations
596	are historical artefacts only. */
597	find_anchor:
598	while (t < strend - prog->minlen) {
599	if (*t == '\n') {
600	if (t < s - prog->check_offset_min) {
601	if (prog->anchored_substr) {
602	/* We definitely contradict the found anchored
603	substr. Due to the above check we do not
604	contradict "check" substr.
605	Thus we can arrive here only if check substr
606	is float. Redo checking for "other"=="fixed".
607	*/
608	strpos = t + 1;
609	DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n",
610	PL_colors[0],PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset)));
611	goto do_other_anchored;
612	}
613	s = t + 1;
614	DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n",
615	PL_colors[0],PL_colors[1], (long)(s - i_strpos)));
616	goto set_useful;
617	}
618	DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting at offset %ld...\n",
619	PL_colors[0],PL_colors[1], (long)(t + 1 - i_strpos)));
620	strpos = s = t + 1;
621	goto restart;
622	}
623	t++;
624	}
625	DEBUG_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n",
626	PL_colors[0],PL_colors[1]));
627	goto fail_finish;
628	}
629	s = t;
630	set_useful:
631	++BmUSEFUL(prog->check_substr); /* hooray/5 */
632	}
633	else {
634	PL_bostr = tmp;
635	/* The found string does not prohibit matching at beg-of-str
636	- no optimization of calling REx engine can be performed,
637	unless it was an MBOL and we are not after MBOL. */
638	try_at_start:
639	/* Even in this situation we may use MBOL flag if strpos is offset
640	wrt the start of the string. */
641	if (ml_anch && sv
642	&& (strpos + SvCUR(sv) != strend) && strpos[-1] != '\n'
643	/* May be due to an implicit anchor of m{.foo} /
644	&& !(prog->reganch & ROPT_IMPLICIT))
645	{
646	t = strpos;
647	goto find_anchor;
648	}
649	DEBUG_r( if (ml_anch)
650	PerlIO_printf(Perl_debug_log, "Does not contradict /%s^%s/m...\n",
651	PL_colors[0],PL_colors[1]);
652	);
653	success_at_start:
654	if (!(prog->reganch & ROPT_NAUGHTY) /* XXXX If strpos moved? */
655	&& prog->check_substr /* Could be deleted already */
656	&& --BmUSEFUL(prog->check_substr) < 0
657	&& prog->check_substr == prog->float_substr)
658	{
659	/* If flags & SOMETHING - do not do it many times on the same match */
660	SvREFCNT_dec(prog->check_substr);
661	prog->check_substr = Nullsv; /* disable */
662	prog->float_substr = Nullsv; /* clear */
663	s = strpos;
664	/* XXXX This is a remnant of the old implementation. It
665	looks wasteful, since now INTUIT can use many
666	other heuristics. */
667	prog->reganch &= ~RE_USE_INTUIT;
668	}
669	else
670	s = strpos;
671	}
672
673	/* Last resort... */
674	/* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */
675	if (prog->regstclass) {
676	/* minlen == 0 is possible if regstclass is \b or \B,
677	and the fixed substr is ''$.
678	Since minlen is already taken into account, s+1 is before strend;
679	accidentally, minlen >= 1 guaranties no false positives at s + 1
680	even for \b or \B. But (minlen? 1 : 0) below assumes that
681	regstclass does not come from lookahead... */
682	/* If regstclass takes bytelength more than 1: If charlength==1, OK.
683	This leaves EXACTF only, which is dealt with in find_byclass(). */
684	int cl_l = (PL_regkind[(U8)OP(prog->regstclass)] == EXACT
685	? STR_LEN(prog->regstclass)
686	: 1);
687	char *endpos = (prog->anchored_substr \|\| ml_anch)
688	? s + (prog->minlen? cl_l : 0)
689	: (prog->float_substr ? check_at - start_shift + cl_l
690	: strend) ;
691	char *startpos = sv && SvPOK(sv) ? strend - SvCUR(sv) : s;
692
693	t = s;
694	if (prog->reganch & ROPT_UTF8) {
695	PL_regdata = prog->data; /* Used by REGINCLASS UTF logic */
696	PL_bostr = startpos;
697	}
698	s = find_byclass(prog, prog->regstclass, s, endpos, startpos, 1);
699	if (!s) {
700	#ifdef DEBUGGING
701	char *what;
702	#endif
703	if (endpos == strend) {
704	DEBUG_r( PerlIO_printf(Perl_debug_log,
705	"Could not match STCLASS...\n") );
706	goto fail;
707	}
708	DEBUG_r( PerlIO_printf(Perl_debug_log,
709	"This position contradicts STCLASS...\n") );
710	if ((prog->reganch & ROPT_ANCH) && !ml_anch)
711	goto fail;
712	/* Contradict one of substrings */
713	if (prog->anchored_substr) {
714	if (prog->anchored_substr == check) {
715	DEBUG_r( what = "anchored" );
716	hop_and_restart:
717	PL_regeol = strend; /* Used in HOP() */
718	s = HOPc(t, 1);
719	if (s + start_shift + end_shift > strend) {
720	/* XXXX Should be taken into account earlier? */
721	DEBUG_r( PerlIO_printf(Perl_debug_log,
722	"Could not match STCLASS...\n") );
723	goto fail;
724	}
725	DEBUG_r( PerlIO_printf(Perl_debug_log,
726	"Trying %s substr starting at offset %ld...\n",
727	what, (long)(s + start_shift - i_strpos)) );
728	goto restart;
729	}
730	/* Have both, check_string is floating */
731	if (t + start_shift >= check_at) /* Contradicts floating=check */
732	goto retry_floating_check;
733	/* Recheck anchored substring, but not floating... */
734	s = check_at;
735	DEBUG_r( PerlIO_printf(Perl_debug_log,
736	"Trying anchored substr starting at offset %ld...\n",
737	(long)(other_last - i_strpos)) );
738	goto do_other_anchored;
739	}
740	/* Another way we could have checked stclass at the
741	current position only: */
742	if (ml_anch) {
743	s = t = t + 1;
744	DEBUG_r( PerlIO_printf(Perl_debug_log,
745	"Trying /^/m starting at offset %ld...\n",
746	(long)(t - i_strpos)) );
747	goto try_at_offset;
748	}
749	if (!prog->float_substr) /* Could have been deleted */
750	goto fail;
751	/* Check is floating subtring. */
752	retry_floating_check:
753	t = check_at - start_shift;
754	DEBUG_r( what = "floating" );
755	goto hop_and_restart;
756	}
757	DEBUG_r( if (t != s)
758	PerlIO_printf(Perl_debug_log,
759	"By STCLASS: moving %ld --> %ld\n",
760	(long)(t - i_strpos), (long)(s - i_strpos));
761	else
762	PerlIO_printf(Perl_debug_log,
763	"Does not contradict STCLASS...\n") );
764	}
765	DEBUG_r(PerlIO_printf(Perl_debug_log, "%sGuessed:%s match at offset %ld\n",
766	PL_colors[4], PL_colors[5], (long)(s - i_strpos)) );
767	return s;
768
769	fail_finish: /* Substring not found */
770	if (prog->check_substr) /* could be removed already */
771	BmUSEFUL(prog->check_substr) += 5; /* hooray */
772	fail:
773	DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
774	PL_colors[4],PL_colors[5]));
775	return Nullch;
776	}
777
778	/* We know what class REx starts with. Try to find this position... */
779	STATIC char *
780	S_find_byclass(pTHX_ regexp * prog, regnode c, char s, char strend, char startpos, I32 norun)
781	{
782	I32 doevery = (prog->reganch & ROPT_SKIP) == 0;
783	char *m;
784	STRLEN ln;
785	unsigned int c1;
786	unsigned int c2;
787	char *e;
788	register I32 tmp = 1; /* Scratch variable? */
789
790	/* We know what class it must start with. */
791	switch (OP(c)) {
792	case ANYOFUTF8:
793	while (s < strend) {
794	if (REGINCLASSUTF8(c, (U8*)s)) {
795	if (tmp && (norun \|\| regtry(prog, s)))
796	goto got_it;
797	else
798	tmp = doevery;
799	}
800	else
801	tmp = 1;
802	s += UTF8SKIP(s);
803	}
804	break;
805	case ANYOF:
806	while (s < strend) {
807	if (REGINCLASS(c, (U8)s)) {
808	if (tmp && (norun \|\| regtry(prog, s)))
809	goto got_it;
810	else
811	tmp = doevery;
812	}
813	else
814	tmp = 1;
815	s++;
816	}
817	break;
818	case EXACTF:
819	m = STRING(c);
820	ln = STR_LEN(c);
821	c1 = (U8)m;
822	c2 = PL_fold[c1];
823	goto do_exactf;
824	case EXACTFL:
825	m = STRING(c);
826	ln = STR_LEN(c);
827	c1 = (U8)m;
828	c2 = PL_fold_locale[c1];
829	do_exactf:
830	e = strend - ln;
831
832	if (norun && e < s)
833	e = s; /* Due to minlen logic of intuit() */
834	/* Here it is NOT UTF! */
835	if (c1 == c2) {
836	while (s <= e) {
837	if ( (U8)s == c1
838	&& (ln == 1 \|\| !(OP(c) == EXACTF
839	? ibcmp(s, m, ln)
840	: ibcmp_locale(s, m, ln)))
841	&& (norun \|\| regtry(prog, s)) )
842	goto got_it;
843	s++;
844	}
845	} else {
846	while (s <= e) {
847	if ( ((U8)s == c1 \|\| (U8)s == c2)
848	&& (ln == 1 \|\| !(OP(c) == EXACTF
849	? ibcmp(s, m, ln)
850	: ibcmp_locale(s, m, ln)))
851	&& (norun \|\| regtry(prog, s)) )
852	goto got_it;
853	s++;
854	}
855	}
856	break;
857	case BOUNDL:
858	PL_reg_flags \|= RF_tainted;
859	/* FALL THROUGH */
860	case BOUND:
861	tmp = (s != startpos) ? UCHARAT(s - 1) : '\n';
862	tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
863	while (s < strend) {
864	if (tmp == !(OP(c) == BOUND ? isALNUM(s) : isALNUM_LC(s))) {
865	tmp = !tmp;
866	if ((norun \|\| regtry(prog, s)))
867	goto got_it;
868	}
869	s++;
870	}
871	if ((!prog->minlen && tmp) && (norun \|\| regtry(prog, s)))
872	goto got_it;
873	break;
874	case BOUNDLUTF8:
875	PL_reg_flags \|= RF_tainted;
876	/* FALL THROUGH */
877	case BOUNDUTF8:
878	tmp = (I32)(s != startpos) ? utf8_to_uv(reghop((U8*)s, -1), 0) : '\n';
879	tmp = ((OP(c) == BOUNDUTF8 ? isALNUM_uni(tmp) : isALNUM_LC_uni(tmp)) != 0);
880	while (s < strend) {
881	if (tmp == !(OP(c) == BOUNDUTF8 ?
882	swash_fetch(PL_utf8_alnum, (U8*)s) :
883	isALNUM_LC_utf8((U8*)s)))
884	{
885	tmp = !tmp;
886	if ((norun \|\| regtry(prog, s)))
887	goto got_it;
888	}
889	s += UTF8SKIP(s);
890	}
891	if ((!prog->minlen && tmp) && (norun \|\| regtry(prog, s)))
892	goto got_it;
893	break;
894	case NBOUNDL:
895	PL_reg_flags \|= RF_tainted;
896	/* FALL THROUGH */
897	case NBOUND:
898	tmp = (s != startpos) ? UCHARAT(s - 1) : '\n';
899	tmp = ((OP(c) == NBOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
900	while (s < strend) {
901	if (tmp == !(OP(c) == NBOUND ? isALNUM(s) : isALNUM_LC(s)))
902	tmp = !tmp;
903	else if ((norun \|\| regtry(prog, s)))
904	goto got_it;
905	s++;
906	}
907	if ((!prog->minlen && !tmp) && (norun \|\| regtry(prog, s)))
908	goto got_it;
909	break;
910	case NBOUNDLUTF8:
911	PL_reg_flags \|= RF_tainted;
912	/* FALL THROUGH */
913	case NBOUNDUTF8:
914	tmp = (I32)(s != startpos) ? utf8_to_uv(reghop((U8*)s, -1), 0) : '\n';
915	tmp = ((OP(c) == NBOUNDUTF8 ? isALNUM_uni(tmp) : isALNUM_LC_uni(tmp)) != 0);
916	while (s < strend) {
917	if (tmp == !(OP(c) == NBOUNDUTF8 ?
918	swash_fetch(PL_utf8_alnum, (U8*)s) :
919	isALNUM_LC_utf8((U8*)s)))
920	tmp = !tmp;
921	else if ((norun \|\| regtry(prog, s)))
922	goto got_it;
923	s += UTF8SKIP(s);
924	}
925	if ((!prog->minlen && !tmp) && (norun \|\| regtry(prog, s)))
926	goto got_it;
927	break;
928	case ALNUM:
929	while (s < strend) {
930	if (isALNUM(*s)) {
931	if (tmp && (norun \|\| regtry(prog, s)))
932	goto got_it;
933	else
934	tmp = doevery;
935	}
936	else
937	tmp = 1;
938	s++;
939	}
940	break;
941	case ALNUMUTF8:
942	while (s < strend) {
943	if (swash_fetch(PL_utf8_alnum, (U8*)s)) {
944	if (tmp && (norun \|\| regtry(prog, s)))
945	goto got_it;
946	else
947	tmp = doevery;
948	}
949	else
950	tmp = 1;
951	s += UTF8SKIP(s);
952	}
953	break;
954	case ALNUML:
955	PL_reg_flags \|= RF_tainted;
956	while (s < strend) {
957	if (isALNUM_LC(*s)) {
958	if (tmp && (norun \|\| regtry(prog, s)))
959	goto got_it;
960	else
961	tmp = doevery;
962	}
963	else
964	tmp = 1;
965	s++;
966	}
967	break;
968	case ALNUMLUTF8:
969	PL_reg_flags \|= RF_tainted;
970	while (s < strend) {
971	if (isALNUM_LC_utf8((U8*)s)) {
972	if (tmp && (norun \|\| regtry(prog, s)))
973	goto got_it;
974	else
975	tmp = doevery;
976	}
977	else
978	tmp = 1;
979	s += UTF8SKIP(s);
980	}
981	break;
982	case NALNUM:
983	while (s < strend) {
984	if (!isALNUM(*s)) {
985	if (tmp && (norun \|\| regtry(prog, s)))
986	goto got_it;
987	else
988	tmp = doevery;
989	}
990	else
991	tmp = 1;
992	s++;
993	}
994	break;
995	case NALNUMUTF8:
996	while (s < strend) {
997	if (!swash_fetch(PL_utf8_alnum, (U8*)s)) {
998	if (tmp && (norun \|\| regtry(prog, s)))
999	goto got_it;
1000	else
1001	tmp = doevery;
1002	}
1003	else
1004	tmp = 1;
1005	s += UTF8SKIP(s);
1006	}
1007	break;
1008	case NALNUML:
1009	PL_reg_flags \|= RF_tainted;
1010	while (s < strend) {
1011	if (!isALNUM_LC(*s)) {
1012	if (tmp && (norun \|\| regtry(prog, s)))
1013	goto got_it;
1014	else
1015	tmp = doevery;
1016	}
1017	else
1018	tmp = 1;
1019	s++;
1020	}
1021	break;
1022	case NALNUMLUTF8:
1023	PL_reg_flags \|= RF_tainted;
1024	while (s < strend) {
1025	if (!isALNUM_LC_utf8((U8*)s)) {
1026	if (tmp && (norun \|\| regtry(prog, s)))
1027	goto got_it;
1028	else
1029	tmp = doevery;
1030	}
1031	else
1032	tmp = 1;
1033	s += UTF8SKIP(s);
1034	}
1035	break;
1036	case SPACE:
1037	while (s < strend) {
1038	if (isSPACE(*s)) {
1039	if (tmp && (norun \|\| regtry(prog, s)))
1040	goto got_it;
1041	else
1042	tmp = doevery;
1043	}
1044	else
1045	tmp = 1;
1046	s++;
1047	}
1048	break;
1049	case SPACEUTF8:
1050	while (s < strend) {
1051	if (s == ' ' \|\| swash_fetch(PL_utf8_space,(U8)s)) {
1052	if (tmp && (norun \|\| regtry(prog, s)))
1053	goto got_it;
1054	else
1055	tmp = doevery;
1056	}
1057	else
1058	tmp = 1;
1059	s += UTF8SKIP(s);
1060	}
1061	break;
1062	case SPACEL:
1063	PL_reg_flags \|= RF_tainted;
1064	while (s < strend) {
1065	if (isSPACE_LC(*s)) {
1066	if (tmp && (norun \|\| regtry(prog, s)))
1067	goto got_it;
1068	else
1069	tmp = doevery;
1070	}
1071	else
1072	tmp = 1;
1073	s++;
1074	}
1075	break;
1076	case SPACELUTF8:
1077	PL_reg_flags \|= RF_tainted;
1078	while (s < strend) {
1079	if (s == ' ' \|\| isSPACE_LC_utf8((U8)s)) {
1080	if (tmp && (norun \|\| regtry(prog, s)))
1081	goto got_it;
1082	else
1083	tmp = doevery;
1084	}
1085	else
1086	tmp = 1;
1087	s += UTF8SKIP(s);
1088	}
1089	break;
1090	case NSPACE:
1091	while (s < strend) {
1092	if (!isSPACE(*s)) {
1093	if (tmp && (norun \|\| regtry(prog, s)))
1094	goto got_it;
1095	else
1096	tmp = doevery;
1097	}
1098	else
1099	tmp = 1;
1100	s++;
1101	}
1102	break;
1103	case NSPACEUTF8:
1104	while (s < strend) {
1105	if (!(s == ' ' \|\| swash_fetch(PL_utf8_space,(U8)s))) {
1106	if (tmp && (norun \|\| regtry(prog, s)))
1107	goto got_it;
1108	else
1109	tmp = doevery;
1110	}
1111	else
1112	tmp = 1;
1113	s += UTF8SKIP(s);
1114	}
1115	break;
1116	case NSPACEL:
1117	PL_reg_flags \|= RF_tainted;
1118	while (s < strend) {
1119	if (!isSPACE_LC(*s)) {
1120	if (tmp && (norun \|\| regtry(prog, s)))
1121	goto got_it;
1122	else
1123	tmp = doevery;
1124	}
1125	else
1126	tmp = 1;
1127	s++;
1128	}
1129	break;
1130	case NSPACELUTF8:
1131	PL_reg_flags \|= RF_tainted;
1132	while (s < strend) {
1133	if (!(s == ' ' \|\| isSPACE_LC_utf8((U8)s))) {
1134	if (tmp && (norun \|\| regtry(prog, s)))
1135	goto got_it;
1136	else
1137	tmp = doevery;
1138	}
1139	else
1140	tmp = 1;
1141	s += UTF8SKIP(s);
1142	}
1143	break;
1144	case DIGIT:
1145	while (s < strend) {
1146	if (isDIGIT(*s)) {
1147	if (tmp && (norun \|\| regtry(prog, s)))
1148	goto got_it;
1149	else
1150	tmp = doevery;
1151	}
1152	else
1153	tmp = 1;
1154	s++;
1155	}
1156	break;
1157	case DIGITUTF8:
1158	while (s < strend) {
1159	if (swash_fetch(PL_utf8_digit,(U8*)s)) {
1160	if (tmp && (norun \|\| regtry(prog, s)))
1161	goto got_it;
1162	else
1163	tmp = doevery;
1164	}
1165	else
1166	tmp = 1;
1167	s += UTF8SKIP(s);
1168	}
1169	break;
1170	case DIGITL:
1171	PL_reg_flags \|= RF_tainted;
1172	while (s < strend) {
1173	if (isDIGIT_LC(*s)) {
1174	if (tmp && (norun \|\| regtry(prog, s)))
1175	goto got_it;
1176	else
1177	tmp = doevery;
1178	}
1179	else
1180	tmp = 1;
1181	s++;
1182	}
1183	break;
1184	case DIGITLUTF8:
1185	PL_reg_flags \|= RF_tainted;
1186	while (s < strend) {
1187	if (isDIGIT_LC_utf8((U8*)s)) {
1188	if (tmp && (norun \|\| regtry(prog, s)))
1189	goto got_it;
1190	else
1191	tmp = doevery;
1192	}
1193	else
1194	tmp = 1;
1195	s += UTF8SKIP(s);
1196	}
1197	break;
1198	case NDIGIT:
1199	while (s < strend) {
1200	if (!isDIGIT(*s)) {
1201	if (tmp && (norun \|\| regtry(prog, s)))
1202	goto got_it;
1203	else
1204	tmp = doevery;
1205	}
1206	else
1207	tmp = 1;
1208	s++;
1209	}
1210	break;
1211	case NDIGITUTF8:
1212	while (s < strend) {
1213	if (!swash_fetch(PL_utf8_digit,(U8*)s)) {
1214	if (tmp && (norun \|\| regtry(prog, s)))
1215	goto got_it;
1216	else
1217	tmp = doevery;
1218	}
1219	else
1220	tmp = 1;
1221	s += UTF8SKIP(s);
1222	}
1223	break;
1224	case NDIGITL:
1225	PL_reg_flags \|= RF_tainted;
1226	while (s < strend) {
1227	if (!isDIGIT_LC(*s)) {
1228	if (tmp && (norun \|\| regtry(prog, s)))
1229	goto got_it;
1230	else
1231	tmp = doevery;
1232	}
1233	else
1234	tmp = 1;
1235	s++;
1236	}
1237	break;
1238	case NDIGITLUTF8:
1239	PL_reg_flags \|= RF_tainted;
1240	while (s < strend) {
1241	if (!isDIGIT_LC_utf8((U8*)s)) {
1242	if (tmp && (norun \|\| regtry(prog, s)))
1243	goto got_it;
1244	else
1245	tmp = doevery;
1246	}
1247	else
1248	tmp = 1;
1249	s += UTF8SKIP(s);
1250	}
1251	break;
1252	default:
1253	Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
1254	break;
1255	}
1256	return 0;
1257	got_it:
1258	return s;
1259	}
1260
1261	/*
1262	- regexec_flags - match a regexp against a string
1263	*/
1264	I32
1265	Perl_regexec_flags(pTHX_ register regexp prog, char stringarg, register char *strend,
1266	char strbeg, I32 minend, SV sv, void *data, U32 flags)
1267	/* strend: pointer to null at end of string */
1268	/* strbeg: real beginning of string */
1269	/* minend: end of match must be >=minend after stringarg. */
1270	/* data: May be used for some additional optimizations. */
1271	/* nosave: For optimizations. */
1272	{
1273	dTHR;
1274	register char *s;
1275	register regnode *c;
1276	register char *startpos = stringarg;
1277	I32 minlen; /* must match at least this many chars */
1278	I32 dontbother = 0; /* how many characters not to try at end */
1279	/* I32 start_shift = 0; / / Offset of the start to find
1280	constant substr. / / CC */
1281	I32 end_shift = 0; /* Same for the end. / / CC */
1282	I32 scream_pos = -1; /* Internal iterator of scream. */
1283	char *scream_olds;
1284	SV* oreplsv = GvSV(PL_replgv);
1285
1286	PL_regcc = 0;
1287
1288	cache_re(prog);
1289	#ifdef DEBUGGING
1290	PL_regnarrate = PL_debug & 512;
1291	#endif
1292
1293	/* Be paranoid... */
1294	if (prog == NULL \|\| startpos == NULL) {
1295	Perl_croak(aTHX_ "NULL regexp parameter");
1296	return 0;
1297	}
1298
1299	minlen = prog->minlen;
1300	if (strend - startpos < minlen) goto phooey;
1301
1302	if (startpos == strbeg) /* is ^ valid at stringarg? */
1303	PL_regprev = '\n';
1304	else {
1305	PL_regprev = (U32)stringarg[-1];
1306	if (!PL_multiline && PL_regprev == '\n')
1307	PL_regprev = '\0'; /* force ^ to NOT match */
1308	}
1309
1310	/* Check validity of program. */
1311	if (UCHARAT(prog->program) != REG_MAGIC) {
1312	Perl_croak(aTHX_ "corrupted regexp program");
1313	}
1314
1315	PL_reg_flags = 0;
1316	PL_reg_eval_set = 0;
1317	PL_reg_maxiter = 0;
1318
1319	if (prog->reganch & ROPT_UTF8)
1320	PL_reg_flags \|= RF_utf8;
1321
1322	/* Mark beginning of line for ^ and lookbehind. */
1323	PL_regbol = startpos;
1324	PL_bostr = strbeg;
1325	PL_reg_sv = sv;
1326
1327	/* Mark end of line for $ (and such) */
1328	PL_regeol = strend;
1329
1330	/* see how far we have to get to not match where we matched before */
1331	PL_regtill = startpos+minend;
1332
1333	/* We start without call_cc context. */
1334	PL_reg_call_cc = 0;
1335
1336	/* If there is a "must appear" string, look for it. */
1337	s = startpos;
1338
1339	if (prog->reganch & ROPT_GPOS_SEEN) { /* Need to have PL_reg_ganch */
1340	MAGIC *mg;
1341
1342	if (flags & REXEC_IGNOREPOS) /* Means: check only at start */
1343	PL_reg_ganch = startpos;
1344	else if (sv && SvTYPE(sv) >= SVt_PVMG
1345	&& SvMAGIC(sv)
1346	&& (mg = mg_find(sv, 'g')) && mg->mg_len >= 0) {
1347	PL_reg_ganch = strbeg + mg->mg_len; /* Defined pos() */
1348	if (prog->reganch & ROPT_ANCH_GPOS) {
1349	if (s > PL_reg_ganch)
1350	goto phooey;
1351	s = PL_reg_ganch;
1352	}
1353	}
1354	else /* pos() not defined */
1355	PL_reg_ganch = strbeg;
1356	}
1357
1358	if (!(flags & REXEC_CHECKED) && prog->check_substr != Nullsv) {
1359	re_scream_pos_data d;
1360
1361	d.scream_olds = &scream_olds;
1362	d.scream_pos = &scream_pos;
1363	s = re_intuit_start(prog, sv, s, strend, flags, &d);
1364	if (!s)
1365	goto phooey; /* not present */
1366	}
1367
1368	DEBUG_r( if (!PL_colorset) reginitcolors() );
1369	DEBUG_r(PerlIO_printf(Perl_debug_log,
1370	"%sMatching REx%s `%s%.60s%s%s' against `%s%.*s%s%s'\n",
1371	PL_colors[4],PL_colors[5],PL_colors[0],
1372	prog->precomp,
1373	PL_colors[1],
1374	(strlen(prog->precomp) > 60 ? "..." : ""),
1375	PL_colors[0],
1376	(int)(strend - startpos > 60 ? 60 : strend - startpos),
1377	startpos, PL_colors[1],
1378	(strend - startpos > 60 ? "..." : ""))
1379	);
1380
1381	/* Simplest case: anchored match need be tried only once. */
1382	/* [unless only anchor is BOL and multiline is set] */
1383	if (prog->reganch & (ROPT_ANCH & ~ROPT_ANCH_GPOS)) {
1384	if (s == startpos && regtry(prog, startpos))
1385	goto got_it;
1386	else if (PL_multiline \|\| (prog->reganch & ROPT_IMPLICIT)
1387	\|\| (prog->reganch & ROPT_ANCH_MBOL)) /* XXXX SBOL? */
1388	{
1389	char *end;
1390
1391	if (minlen)
1392	dontbother = minlen - 1;
1393	end = HOPc(strend, -dontbother) - 1;
1394	/* for multiline we only have to try after newlines */
1395	if (prog->check_substr) {
1396	if (s == startpos)
1397	goto after_try;
1398	while (1) {
1399	if (regtry(prog, s))
1400	goto got_it;
1401	after_try:
1402	if (s >= end)
1403	goto phooey;
1404	if (prog->reganch & RE_USE_INTUIT) {
1405	s = re_intuit_start(prog, sv, s + 1, strend, flags, NULL);
1406	if (!s)
1407	goto phooey;
1408	}
1409	else
1410	s++;
1411	}
1412	} else {
1413	if (s > startpos)
1414	s--;
1415	while (s < end) {
1416	if (s++ == '\n') { / don't need PL_utf8skip here */
1417	if (regtry(prog, s))
1418	goto got_it;
1419	}
1420	}
1421	}
1422	}
1423	goto phooey;
1424	} else if (prog->reganch & ROPT_ANCH_GPOS) {
1425	if (regtry(prog, PL_reg_ganch))
1426	goto got_it;
1427	goto phooey;
1428	}
1429
1430	/* Messy cases: unanchored match. */
1431	if (prog->anchored_substr && prog->reganch & ROPT_SKIP) {
1432	/* we have /x+whatever/ */
1433	/* it must be a one character string (XXXX Except UTF?) */
1434	char ch = SvPVX(prog->anchored_substr)[0];
1435	if (UTF) {
1436	while (s < strend) {
1437	if (*s == ch) {
1438	if (regtry(prog, s)) goto got_it;
1439	s += UTF8SKIP(s);
1440	while (s < strend && *s == ch)
1441	s += UTF8SKIP(s);
1442	}
1443	s += UTF8SKIP(s);
1444	}
1445	}
1446	else {
1447	while (s < strend) {
1448	if (*s == ch) {
1449	if (regtry(prog, s)) goto got_it;
1450	s++;
1451	while (s < strend && *s == ch)
1452	s++;
1453	}
1454	s++;
1455	}
1456	}
1457	}
1458	/SUPPRESS 560/
1459	else if (prog->anchored_substr != Nullsv
1460	\|\| (prog->float_substr != Nullsv
1461	&& prog->float_max_offset < strend - s)) {
1462	SV *must = prog->anchored_substr
1463	? prog->anchored_substr : prog->float_substr;
1464	I32 back_max =
1465	prog->anchored_substr ? prog->anchored_offset : prog->float_max_offset;
1466	I32 back_min =
1467	prog->anchored_substr ? prog->anchored_offset : prog->float_min_offset;
1468	char last = HOPc(strend, / Cannot start after this */
1469	-(I32)(CHR_SVLEN(must)
1470	- (SvTAIL(must) != 0) + back_min));
1471	char last1; / Last position checked before */
1472
1473	if (s > PL_bostr)
1474	last1 = HOPc(s, -1);
1475	else
1476	last1 = s - 1; /* bogus */
1477
1478	/* XXXX check_substr already used to find `s', can optimize if
1479	check_substr==must. */
1480	scream_pos = -1;
1481	dontbother = end_shift;
1482	strend = HOPc(strend, -dontbother);
1483	while ( (s <= last) &&
1484	((flags & REXEC_SCREAM)
1485	? (s = screaminstr(sv, must, HOPc(s, back_min) - strbeg,
1486	end_shift, &scream_pos, 0))
1487	: (s = fbm_instr((unsigned char*)HOP(s, back_min),
1488	(unsigned char*)strend, must,
1489	PL_multiline ? FBMrf_MULTILINE : 0))) ) {
1490	if (HOPc(s, -back_max) > last1) {
1491	last1 = HOPc(s, -back_min);
1492	s = HOPc(s, -back_max);
1493	}
1494	else {
1495	char *t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
1496
1497	last1 = HOPc(s, -back_min);
1498	s = t;
1499	}
1500	if (UTF) {
1501	while (s <= last1) {
1502	if (regtry(prog, s))
1503	goto got_it;
1504	s += UTF8SKIP(s);
1505	}
1506	}
1507	else {
1508	while (s <= last1) {
1509	if (regtry(prog, s))
1510	goto got_it;
1511	s++;
1512	}
1513	}
1514	}
1515	goto phooey;
1516	}
1517	else if ((c = prog->regstclass)) {
1518	if (minlen && PL_regkind[(U8)OP(prog->regstclass)] != EXACT)
1519	/* don't bother with what can't match */
1520	strend = HOPc(strend, -(minlen - 1));
1521	if (find_byclass(prog, c, s, strend, startpos, 0))
1522	goto got_it;
1523	}
1524	else {
1525	dontbother = 0;
1526	if (prog->float_substr != Nullsv) { /* Trim the end. */
1527	char *last;
1528
1529	if (flags & REXEC_SCREAM) {
1530	last = screaminstr(sv, prog->float_substr, s - strbeg,
1531	end_shift, &scream_pos, 1); /* last one */
1532	if (!last)
1533	last = scream_olds; /* Only one occurence. */
1534	}
1535	else {
1536	STRLEN len;
1537	char *little = SvPV(prog->float_substr, len);
1538
1539	if (SvTAIL(prog->float_substr)) {
1540	if (memEQ(strend - len + 1, little, len - 1))
1541	last = strend - len + 1;
1542	else if (!PL_multiline)
1543	last = memEQ(strend - len, little, len)
1544	? strend - len : Nullch;
1545	else
1546	goto find_last;
1547	} else {
1548	find_last:
1549	if (len)
1550	last = rninstr(s, strend, little, little + len);
1551	else
1552	last = strend; /* matching `$' */
1553	}
1554	}
1555	if (last == NULL) goto phooey; /* Should not happen! */
1556	dontbother = strend - last + prog->float_min_offset;
1557	}
1558	if (minlen && (dontbother < minlen))
1559	dontbother = minlen - 1;
1560	strend -= dontbother; /* this one's always in bytes! */
1561	/* We don't know much -- general case. */
1562	if (UTF) {
1563	for (;;) {
1564	if (regtry(prog, s))
1565	goto got_it;
1566	if (s >= strend)
1567	break;
1568	s += UTF8SKIP(s);
1569	};
1570	}
1571	else {
1572	do {
1573	if (regtry(prog, s))
1574	goto got_it;
1575	} while (s++ < strend);
1576	}
1577	}
1578
1579	/* Failure. */
1580	goto phooey;
1581
1582	got_it:
1583	RX_MATCH_TAINTED_set(prog, PL_reg_flags & RF_tainted);
1584
1585	if (PL_reg_eval_set) {
1586	/* Preserve the current value of $^R */
1587	if (oreplsv != GvSV(PL_replgv))
1588	sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is
1589	restored, the value remains
1590	the same. */
1591	restore_pos(aTHXo_ 0);
1592	}
1593
1594	/* make sure $`, $&, $', and $digit will work later */
1595	if ( !(flags & REXEC_NOT_FIRST) ) {
1596	if (RX_MATCH_COPIED(prog)) {
1597	Safefree(prog->subbeg);
1598	RX_MATCH_COPIED_off(prog);
1599	}
1600	if (flags & REXEC_COPY_STR) {
1601	I32 i = PL_regeol - startpos + (stringarg - strbeg);
1602
1603	s = savepvn(strbeg, i);
1604	prog->subbeg = s;
1605	prog->sublen = i;
1606	RX_MATCH_COPIED_on(prog);
1607	}
1608	else {
1609	prog->subbeg = strbeg;
1610	prog->sublen = PL_regeol - strbeg; /* strend may have been modified */
1611	}
1612	}
1613
1614	return 1;
1615
1616	phooey:
1617	if (PL_reg_eval_set)
1618	restore_pos(aTHXo_ 0);
1619	return 0;
1620	}
1621
1622	/*
1623	- regtry - try match at specific point
1624	*/
1625	STATIC I32 /* 0 failure, 1 success */
1626	S_regtry(pTHX_ regexp prog, char startpos)
1627	{
1628	dTHR;
1629	register I32 i;
1630	register I32 *sp;
1631	register I32 *ep;
1632	CHECKPOINT lastcp;
1633
1634	if ((prog->reganch & ROPT_EVAL_SEEN) && !PL_reg_eval_set) {
1635	MAGIC *mg;
1636
1637	PL_reg_eval_set = RS_init;
1638	DEBUG_r(DEBUG_s(
1639	PerlIO_printf(Perl_debug_log, " setting stack tmpbase at %"IVdf"\n",
1640	(IV)(PL_stack_sp - PL_stack_base));
1641	));
1642	SAVEI32(cxstack[cxstack_ix].blk_oldsp);
1643	cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
1644	/* Otherwise OP_NEXTSTATE will free whatever on stack now. */
1645	SAVETMPS;
1646	/* Apparently this is not needed, judging by wantarray. */
1647	/* SAVEI8(cxstack[cxstack_ix].blk_gimme);
1648	cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
1649
1650	if (PL_reg_sv) {
1651	/* Make $_ available to executed code. */
1652	if (PL_reg_sv != DEFSV) {
1653	/* SAVE_DEFSV does not suffice here for USE_THREADS */
1654	SAVESPTR(DEFSV);
1655	DEFSV = PL_reg_sv;
1656	}
1657
1658	if (!(SvTYPE(PL_reg_sv) >= SVt_PVMG && SvMAGIC(PL_reg_sv)
1659	&& (mg = mg_find(PL_reg_sv, 'g')))) {
1660	/* prepare for quick setting of pos */
1661	sv_magic(PL_reg_sv, (SV*)0, 'g', Nullch, 0);
1662	mg = mg_find(PL_reg_sv, 'g');
1663	mg->mg_len = -1;
1664	}
1665	PL_reg_magic = mg;
1666	PL_reg_oldpos = mg->mg_len;
1667	SAVEDESTRUCTOR_X(restore_pos, 0);
1668	}
1669	if (!PL_reg_curpm)
1670	Newz(22,PL_reg_curpm, 1, PMOP);
1671	PL_reg_curpm->op_pmregexp = prog;
1672	PL_reg_oldcurpm = PL_curpm;
1673	PL_curpm = PL_reg_curpm;
1674	if (RX_MATCH_COPIED(prog)) {
1675	/* Here is a serious problem: we cannot rewrite subbeg,
1676	since it may be needed if this match fails. Thus
1677	$` inside (?{}) could fail... */
1678	PL_reg_oldsaved = prog->subbeg;
1679	PL_reg_oldsavedlen = prog->sublen;
1680	RX_MATCH_COPIED_off(prog);
1681	}
1682	else
1683	PL_reg_oldsaved = Nullch;
1684	prog->subbeg = PL_bostr;
1685	prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
1686	}
1687	prog->startp[0] = startpos - PL_bostr;
1688	PL_reginput = startpos;
1689	PL_regstartp = prog->startp;
1690	PL_regendp = prog->endp;
1691	PL_reglastparen = &prog->lastparen;
1692	prog->lastparen = 0;
1693	PL_regsize = 0;
1694	DEBUG_r(PL_reg_starttry = startpos);
1695	if (PL_reg_start_tmpl <= prog->nparens) {
1696	PL_reg_start_tmpl = prog->nparens*3/2 + 3;
1697	if(PL_reg_start_tmp)
1698	Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
1699	else
1700	New(22,PL_reg_start_tmp, PL_reg_start_tmpl, char*);
1701	}
1702
1703	/* XXXX What this code is doing here?!!! There should be no need
1704	to do this again and again, PL_reglastparen should take care of
1705	this! */
1706	sp = prog->startp;
1707	ep = prog->endp;
1708	if (prog->nparens) {
1709	for (i = prog->nparens; i >= 1; i--) {
1710	*++sp = -1;
1711	*++ep = -1;
1712	}
1713	}
1714	REGCP_SET;
1715	if (regmatch(prog->program + 1)) {
1716	prog->endp[0] = PL_reginput - PL_bostr;
1717	return 1;
1718	}
1719	REGCP_UNWIND;
1720	return 0;
1721	}
1722
1723	/*
1724	- regmatch - main matching routine
1725	*
1726	* Conceptually the strategy is simple: check to see whether the current
1727	* node matches, call self recursively to see whether the rest matches,
1728	* and then act accordingly. In practice we make some effort to avoid
1729	* recursion, in particular by going through "ordinary" nodes (that don't
1730	* need to know whether the rest of the match failed) by a loop instead of
1731	* by recursion.
1732	*/
1733	/* [lwall] I've hoisted the register declarations to the outer block in order to
1734	* maybe save a little bit of pushing and popping on the stack. It also takes
1735	* advantage of machines that use a register save mask on subroutine entry.
1736	*/
1737	STATIC I32 /* 0 failure, 1 success */
1738	S_regmatch(pTHX_ regnode *prog)
1739	{
1740	dTHR;
1741	register regnode scan; / Current node. */
1742	regnode next; / Next node. */
1743	regnode inner; / Next node in internal branch. */
1744	register I32 nextchr; /* renamed nextchr - nextchar colides with
1745	function of same name */
1746	register I32 n; /* no or next */
1747	register I32 ln; /* len or last */
1748	register char s; / operand or save */
1749	register char *locinput = PL_reginput;
1750	register I32 c1, c2, paren; /* case fold search, parenth */
1751	int minmod = 0, sw = 0, logical = 0;
1752	#ifdef DEBUGGING
1753	PL_regindent++;
1754	#endif
1755
1756	/* Note that nextchr is a byte even in UTF */
1757	nextchr = UCHARAT(locinput);
1758	scan = prog;
1759	while (scan != NULL) {
1760	#define sayNO_L (logical ? (logical = 0, sw = 0, goto cont) : sayNO)
1761	#ifdef DEBUGGING
1762	# define sayYES goto yes
1763	# define sayNO goto no
1764	# define sayYES_FINAL goto yes_final
1765	# define sayYES_LOUD goto yes_loud
1766	# define sayNO_FINAL goto no_final
1767	# define sayNO_SILENT goto do_no
1768	# define saySAME(x) if (x) goto yes; else goto no
1769	# define REPORT_CODE_OFF 24
1770	#else
1771	# define sayYES return 1
1772	# define sayNO return 0
1773	# define sayYES_FINAL return 1
1774	# define sayYES_LOUD return 1
1775	# define sayNO_FINAL return 0
1776	# define sayNO_SILENT return 0
1777	# define saySAME(x) return x
1778	#endif
1779	DEBUG_r( {
1780	SV *prop = sv_newmortal();
1781	int docolor = *PL_colors[0];
1782	int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
1783	int l = (PL_regeol - locinput > taill ? taill : PL_regeol - locinput);
1784	/* The part of the string before starttry has one color
1785	(pref0_len chars), between starttry and current
1786	position another one (pref_len - pref0_len chars),
1787	after the current position the third one.
1788	We assume that pref0_len <= pref_len, otherwise we
1789	decrease pref0_len. */
1790	int pref_len = (locinput - PL_bostr > (5 + taill) - l
1791	? (5 + taill) - l : locinput - PL_bostr);
1792	int pref0_len = pref_len - (locinput - PL_reg_starttry);
1793
1794	if (l + pref_len < (5 + taill) && l < PL_regeol - locinput)
1795	l = ( PL_regeol - locinput > (5 + taill) - pref_len
1796	? (5 + taill) - pref_len : PL_regeol - locinput);
1797	if (pref0_len < 0)
1798	pref0_len = 0;
1799	if (pref0_len > pref_len)
1800	pref0_len = pref_len;
1801	regprop(prop, scan);
1802	PerlIO_printf(Perl_debug_log,
1803	"%4"IVdf" <%s%.s%s%s%.s%s%s%s%.s%s>%s\|%3"IVdf":%*s%s\n",
1804	(IV)(locinput - PL_bostr),
1805	PL_colors[4], pref0_len,
1806	locinput - pref_len, PL_colors[5],
1807	PL_colors[2], pref_len - pref0_len,
1808	locinput - pref_len + pref0_len, PL_colors[3],
1809	(docolor ? "" : "> <"),
1810	PL_colors[0], l, locinput, PL_colors[1],
1811	15 - l - pref_len + 1,
1812	"",
1813	(IV)(scan - PL_regprogram), PL_regindent*2, "",
1814	SvPVX(prop));
1815	} );
1816
1817	next = scan + NEXT_OFF(scan);
1818	if (next == scan)
1819	next = NULL;
1820
1821	switch (OP(scan)) {
1822	case BOL:
1823	if (locinput == PL_bostr
1824	? PL_regprev == '\n'
1825	: (PL_multiline &&
1826	(nextchr \|\| locinput < PL_regeol) && locinput[-1] == '\n') )
1827	{
1828	/* regtill = regbol; */
1829	break;
1830	}
1831	sayNO;
1832	case MBOL:
1833	if (locinput == PL_bostr
1834	? PL_regprev == '\n'
1835	: ((nextchr \|\| locinput < PL_regeol) && locinput[-1] == '\n') )
1836	{
1837	break;
1838	}
1839	sayNO;
1840	case SBOL:
1841	if (locinput == PL_regbol && PL_regprev == '\n')
1842	break;
1843	sayNO;
1844	case GPOS:
1845	if (locinput == PL_reg_ganch)
1846	break;
1847	sayNO;
1848	case EOL:
1849	if (PL_multiline)
1850	goto meol;
1851	else
1852	goto seol;
1853	case MEOL:
1854	meol:
1855	if ((nextchr \|\| locinput < PL_regeol) && nextchr != '\n')
1856	sayNO;
1857	break;
1858	case SEOL:
1859	seol:
1860	if ((nextchr \|\| locinput < PL_regeol) && nextchr != '\n')
1861	sayNO;
1862	if (PL_regeol - locinput > 1)
1863	sayNO;
1864	break;
1865	case EOS:
1866	if (PL_regeol != locinput)
1867	sayNO;
1868	break;
1869	case SANYUTF8:
1870	if (nextchr & 0x80) {
1871	locinput += PL_utf8skip[nextchr];
1872	if (locinput > PL_regeol)
1873	sayNO;
1874	nextchr = UCHARAT(locinput);
1875	break;
1876	}
1877	if (!nextchr && locinput >= PL_regeol)
1878	sayNO;
1879	nextchr = UCHARAT(++locinput);
1880	break;
1881	case SANY:
1882	if (!nextchr && locinput >= PL_regeol)
1883	sayNO;
1884	nextchr = UCHARAT(++locinput);
1885	break;
1886	case ANYUTF8:
1887	if (nextchr & 0x80) {
1888	locinput += PL_utf8skip[nextchr];
1889	if (locinput > PL_regeol)
1890	sayNO;
1891	nextchr = UCHARAT(locinput);
1892	break;
1893	}
1894	if ((!nextchr && locinput >= PL_regeol) \|\| nextchr == '\n')
1895	sayNO;
1896	nextchr = UCHARAT(++locinput);
1897	break;
1898	case REG_ANY:
1899	if ((!nextchr && locinput >= PL_regeol) \|\| nextchr == '\n')
1900	sayNO;
1901	nextchr = UCHARAT(++locinput);
1902	break;
1903	case EXACT:
1904	s = STRING(scan);
1905	ln = STR_LEN(scan);
1906	/* Inline the first character, for speed. */
1907	if (UCHARAT(s) != nextchr)
1908	sayNO;
1909	if (PL_regeol - locinput < ln)
1910	sayNO;
1911	if (ln > 1 && memNE(s, locinput, ln))
1912	sayNO;
1913	locinput += ln;
1914	nextchr = UCHARAT(locinput);
1915	break;
1916	case EXACTFL:
1917	PL_reg_flags \|= RF_tainted;
1918	/* FALL THROUGH */
1919	case EXACTF:
1920	s = STRING(scan);
1921	ln = STR_LEN(scan);
1922
1923	if (UTF) {
1924	char *l = locinput;
1925	char *e = s + ln;
1926	c1 = OP(scan) == EXACTF;
1927	while (s < e) {
1928	if (l >= PL_regeol)
1929	sayNO;
1930	if (utf8_to_uv((U8*)s, 0) != (c1 ?
1931	toLOWER_utf8((U8*)l) :
1932	toLOWER_LC_utf8((U8*)l)))
1933	{
1934	sayNO;
1935	}
1936	s += UTF8SKIP(s);
1937	l += UTF8SKIP(l);
1938	}
1939	locinput = l;
1940	nextchr = UCHARAT(locinput);
1941	break;
1942	}
1943
1944	/* Inline the first character, for speed. */
1945	if (UCHARAT(s) != nextchr &&
1946	UCHARAT(s) != ((OP(scan) == EXACTF)
1947	? PL_fold : PL_fold_locale)[nextchr])
1948	sayNO;
1949	if (PL_regeol - locinput < ln)
1950	sayNO;
1951	if (ln > 1 && (OP(scan) == EXACTF
1952	? ibcmp(s, locinput, ln)
1953	: ibcmp_locale(s, locinput, ln)))
1954	sayNO;
1955	locinput += ln;
1956	nextchr = UCHARAT(locinput);
1957	break;
1958	case ANYOFUTF8:
1959	if (!REGINCLASSUTF8(scan, (U8*)locinput))
1960	sayNO;
1961	if (locinput >= PL_regeol)
1962	sayNO;
1963	locinput += PL_utf8skip[nextchr];
1964	nextchr = UCHARAT(locinput);
1965	break;
1966	case ANYOF:
1967	if (nextchr < 0)
1968	nextchr = UCHARAT(locinput);
1969	if (!REGINCLASS(scan, nextchr))
1970	sayNO;
1971	if (!nextchr && locinput >= PL_regeol)
1972	sayNO;
1973	nextchr = UCHARAT(++locinput);
1974	break;
1975	case ALNUML:
1976	PL_reg_flags \|= RF_tainted;
1977	/* FALL THROUGH */
1978	case ALNUM:
1979	if (!nextchr)
1980	sayNO;
1981	if (!(OP(scan) == ALNUM
1982	? isALNUM(nextchr) : isALNUM_LC(nextchr)))
1983	sayNO;
1984	nextchr = UCHARAT(++locinput);
1985	break;
1986	case ALNUMLUTF8:
1987	PL_reg_flags \|= RF_tainted;
1988	/* FALL THROUGH */
1989	case ALNUMUTF8:
1990	if (!nextchr)
1991	sayNO;
1992	if (nextchr & 0x80) {
1993	if (!(OP(scan) == ALNUMUTF8
1994	? swash_fetch(PL_utf8_alnum, (U8*)locinput)
1995	: isALNUM_LC_utf8((U8*)locinput)))
1996	{
1997	sayNO;
1998	}
1999	locinput += PL_utf8skip[nextchr];
2000	nextchr = UCHARAT(locinput);
2001	break;
2002	}
2003	if (!(OP(scan) == ALNUMUTF8
2004	? isALNUM(nextchr) : isALNUM_LC(nextchr)))
2005	sayNO;
2006	nextchr = UCHARAT(++locinput);
2007	break;
2008	case NALNUML:
2009	PL_reg_flags \|= RF_tainted;
2010	/* FALL THROUGH */
2011	case NALNUM:
2012	if (!nextchr && locinput >= PL_regeol)
2013	sayNO;
2014	if (OP(scan) == NALNUM
2015	? isALNUM(nextchr) : isALNUM_LC(nextchr))
2016	sayNO;
2017	nextchr = UCHARAT(++locinput);
2018	break;
2019	case NALNUMLUTF8:
2020	PL_reg_flags \|= RF_tainted;
2021	/* FALL THROUGH */
2022	case NALNUMUTF8:
2023	if (!nextchr && locinput >= PL_regeol)
2024	sayNO;
2025	if (nextchr & 0x80) {
2026	if (OP(scan) == NALNUMUTF8
2027	? swash_fetch(PL_utf8_alnum, (U8*)locinput)
2028	: isALNUM_LC_utf8((U8*)locinput))
2029	{
2030	sayNO;
2031	}
2032	locinput += PL_utf8skip[nextchr];
2033	nextchr = UCHARAT(locinput);
2034	break;
2035	}
2036	if (OP(scan) == NALNUMUTF8
2037	? isALNUM(nextchr) : isALNUM_LC(nextchr))
2038	sayNO;
2039	nextchr = UCHARAT(++locinput);
2040	break;
2041	case BOUNDL:
2042	case NBOUNDL:
2043	PL_reg_flags \|= RF_tainted;
2044	/* FALL THROUGH */
2045	case BOUND:
2046	case NBOUND:
2047	/* was last char in word? */
2048	ln = (locinput != PL_regbol) ? UCHARAT(locinput - 1) : PL_regprev;
2049	if (OP(scan) == BOUND \|\| OP(scan) == NBOUND) {
2050	ln = isALNUM(ln);
2051	n = isALNUM(nextchr);
2052	}
2053	else {
2054	ln = isALNUM_LC(ln);
2055	n = isALNUM_LC(nextchr);
2056	}
2057	if (((!ln) == (!n)) == (OP(scan) == BOUND \|\| OP(scan) == BOUNDL))
2058	sayNO;
2059	break;
2060	case BOUNDLUTF8:
2061	case NBOUNDLUTF8:
2062	PL_reg_flags \|= RF_tainted;
2063	/* FALL THROUGH */
2064	case BOUNDUTF8:
2065	case NBOUNDUTF8:
2066	/* was last char in word? */
2067	ln = (locinput != PL_regbol)
2068	? utf8_to_uv(reghop((U8*)locinput, -1), 0) : PL_regprev;
2069	if (OP(scan) == BOUNDUTF8 \|\| OP(scan) == NBOUNDUTF8) {
2070	ln = isALNUM_uni(ln);
2071	n = swash_fetch(PL_utf8_alnum, (U8*)locinput);
2072	}
2073	else {
2074	ln = isALNUM_LC_uni(ln);
2075	n = isALNUM_LC_utf8((U8*)locinput);
2076	}
2077	if (((!ln) == (!n)) == (OP(scan) == BOUNDUTF8 \|\| OP(scan) == BOUNDLUTF8))
2078	sayNO;
2079	break;
2080	case SPACEL:
2081	PL_reg_flags \|= RF_tainted;
2082	/* FALL THROUGH */
2083	case SPACE:
2084	if (!nextchr)
2085	sayNO;
2086	if (!(OP(scan) == SPACE
2087	? isSPACE(nextchr) : isSPACE_LC(nextchr)))
2088	sayNO;
2089	nextchr = UCHARAT(++locinput);
2090	break;
2091	case SPACELUTF8:
2092	PL_reg_flags \|= RF_tainted;
2093	/* FALL THROUGH */
2094	case SPACEUTF8:
2095	if (!nextchr)
2096	sayNO;
2097	if (nextchr & 0x80) {
2098	if (!(OP(scan) == SPACEUTF8
2099	? swash_fetch(PL_utf8_space, (U8*)locinput)
2100	: isSPACE_LC_utf8((U8*)locinput)))
2101	{
2102	sayNO;
2103	}
2104	locinput += PL_utf8skip[nextchr];
2105	nextchr = UCHARAT(locinput);
2106	break;
2107	}
2108	if (!(OP(scan) == SPACEUTF8
2109	? isSPACE(nextchr) : isSPACE_LC(nextchr)))
2110	sayNO;
2111	nextchr = UCHARAT(++locinput);
2112	break;
2113	case NSPACEL:
2114	PL_reg_flags \|= RF_tainted;
2115	/* FALL THROUGH */
2116	case NSPACE:
2117	if (!nextchr && locinput >= PL_regeol)
2118	sayNO;
2119	if (OP(scan) == NSPACE
2120	? isSPACE(nextchr) : isSPACE_LC(nextchr))
2121	sayNO;
2122	nextchr = UCHARAT(++locinput);
2123	break;
2124	case NSPACELUTF8:
2125	PL_reg_flags \|= RF_tainted;
2126	/* FALL THROUGH */
2127	case NSPACEUTF8:
2128	if (!nextchr && locinput >= PL_regeol)
2129	sayNO;
2130	if (nextchr & 0x80) {
2131	if (OP(scan) == NSPACEUTF8
2132	? swash_fetch(PL_utf8_space, (U8*)locinput)
2133	: isSPACE_LC_utf8((U8*)locinput))
2134	{
2135	sayNO;
2136	}
2137	locinput += PL_utf8skip[nextchr];
2138	nextchr = UCHARAT(locinput);
2139	break;
2140	}
2141	if (OP(scan) == NSPACEUTF8
2142	? isSPACE(nextchr) : isSPACE_LC(nextchr))
2143	sayNO;
2144	nextchr = UCHARAT(++locinput);
2145	break;
2146	case DIGITL:
2147	PL_reg_flags \|= RF_tainted;
2148	/* FALL THROUGH */
2149	case DIGIT:
2150	if (!nextchr)
2151	sayNO;
2152	if (!(OP(scan) == DIGIT
2153	? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
2154	sayNO;
2155	nextchr = UCHARAT(++locinput);
2156	break;
2157	case DIGITLUTF8:
2158	PL_reg_flags \|= RF_tainted;
2159	/* FALL THROUGH */
2160	case DIGITUTF8:
2161	if (!nextchr)
2162	sayNO;
2163	if (nextchr & 0x80) {
2164	if (!(OP(scan) == DIGITUTF8
2165	? swash_fetch(PL_utf8_digit, (U8*)locinput)
2166	: isDIGIT_LC_utf8((U8*)locinput)))
2167	{
2168	sayNO;
2169	}
2170	locinput += PL_utf8skip[nextchr];
2171	nextchr = UCHARAT(locinput);
2172	break;
2173	}
2174	if (!(OP(scan) == DIGITUTF8
2175	? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
2176	sayNO;
2177	nextchr = UCHARAT(++locinput);
2178	break;
2179	case NDIGITL:
2180	PL_reg_flags \|= RF_tainted;
2181	/* FALL THROUGH */
2182	case NDIGIT:
2183	if (!nextchr && locinput >= PL_regeol)
2184	sayNO;
2185	if (OP(scan) == NDIGIT
2186	? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
2187	sayNO;
2188	nextchr = UCHARAT(++locinput);
2189	break;
2190	case NDIGITLUTF8:
2191	PL_reg_flags \|= RF_tainted;
2192	/* FALL THROUGH */
2193	case NDIGITUTF8:
2194	if (!nextchr && locinput >= PL_regeol)
2195	sayNO;
2196	if (nextchr & 0x80) {
2197	if (OP(scan) == NDIGITUTF8
2198	? swash_fetch(PL_utf8_digit, (U8*)locinput)
2199	: isDIGIT_LC_utf8((U8*)locinput))
2200	{
2201	sayNO;
2202	}
2203	locinput += PL_utf8skip[nextchr];
2204	nextchr = UCHARAT(locinput);
2205	break;
2206	}
2207	if (OP(scan) == NDIGITUTF8
2208	? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
2209	sayNO;
2210	nextchr = UCHARAT(++locinput);
2211	break;
2212	case CLUMP:
2213	if (locinput >= PL_regeol \|\| swash_fetch(PL_utf8_mark,(U8*)locinput))
2214	sayNO;
2215	locinput += PL_utf8skip[nextchr];
2216	while (locinput < PL_regeol && swash_fetch(PL_utf8_mark,(U8*)locinput))
2217	locinput += UTF8SKIP(locinput);
2218	if (locinput > PL_regeol)
2219	sayNO;
2220	nextchr = UCHARAT(locinput);
2221	break;
2222	case REFFL:
2223	PL_reg_flags \|= RF_tainted;
2224	/* FALL THROUGH */
2225	case REF:
2226	case REFF:
2227	n = ARG(scan); /* which paren pair */
2228	ln = PL_regstartp[n];
2229	PL_reg_leftiter = PL_reg_maxiter; /* Void cache */
2230	if (*PL_reglastparen < n \|\| ln == -1)
2231	sayNO; /* Do not match unless seen CLOSEn. */
2232	if (ln == PL_regendp[n])
2233	break;
2234
2235	s = PL_bostr + ln;
2236	if (UTF && OP(scan) != REF) { /* REF can do byte comparison */
2237	char *l = locinput;
2238	char *e = PL_bostr + PL_regendp[n];
2239	/*
2240	* Note that we can't do the "other character" lookup trick as
2241	* in the 8-bit case (no pun intended) because in Unicode we
2242	* have to map both upper and title case to lower case.
2243	*/
2244	if (OP(scan) == REFF) {
2245	while (s < e) {
2246	if (l >= PL_regeol)
2247	sayNO;
2248	if (toLOWER_utf8((U8)s) != toLOWER_utf8((U8)l))
2249	sayNO;
2250	s += UTF8SKIP(s);
2251	l += UTF8SKIP(l);
2252	}
2253	}
2254	else {
2255	while (s < e) {
2256	if (l >= PL_regeol)
2257	sayNO;
2258	if (toLOWER_LC_utf8((U8)s) != toLOWER_LC_utf8((U8)l))
2259	sayNO;
2260	s += UTF8SKIP(s);
2261	l += UTF8SKIP(l);
2262	}
2263	}
2264	locinput = l;
2265	nextchr = UCHARAT(locinput);
2266	break;
2267	}
2268
2269	/* Inline the first character, for speed. */
2270	if (UCHARAT(s) != nextchr &&
2271	(OP(scan) == REF \|\|
2272	(UCHARAT(s) != ((OP(scan) == REFF
2273	? PL_fold : PL_fold_locale)[nextchr]))))
2274	sayNO;
2275	ln = PL_regendp[n] - ln;
2276	if (locinput + ln > PL_regeol)
2277	sayNO;
2278	if (ln > 1 && (OP(scan) == REF
2279	? memNE(s, locinput, ln)
2280	: (OP(scan) == REFF
2281	? ibcmp(s, locinput, ln)
2282	: ibcmp_locale(s, locinput, ln))))
2283	sayNO;
2284	locinput += ln;
2285	nextchr = UCHARAT(locinput);
2286	break;
2287
2288	case NOTHING:
2289	case TAIL:
2290	break;
2291	case BACK:
2292	break;
2293	case EVAL:
2294	{
2295	dSP;
2296	OP_4tree *oop = PL_op;
2297	COP *ocurcop = PL_curcop;
2298	SV **ocurpad = PL_curpad;
2299	SV *ret;
2300
2301	n = ARG(scan);
2302	PL_op = (OP_4tree*)PL_regdata->data[n];
2303	DEBUG_r( PerlIO_printf(Perl_debug_log, " re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
2304	PL_curpad = AvARRAY((AV*)PL_regdata->data[n + 2]);
2305	PL_regendp[0] = PL_reg_magic->mg_len = locinput - PL_bostr;
2306
2307	CALLRUNOPS(aTHX); /* Scalar context. */
2308	SPAGAIN;
2309	ret = POPs;
2310	PUTBACK;
2311
2312	PL_op = oop;
2313	PL_curpad = ocurpad;
2314	PL_curcop = ocurcop;
2315	if (logical) {
2316	if (logical == 2) { /* Postponed subexpression. */
2317	regexp *re;
2318	MAGIC mg = Null(MAGIC);
2319	re_cc_state state;
2320	CHECKPOINT cp, lastcp;
2321
2322	if(SvROK(ret) \|\| SvRMAGICAL(ret)) {
2323	SV *sv = SvROK(ret) ? SvRV(ret) : ret;
2324
2325	if(SvMAGICAL(sv))
2326	mg = mg_find(sv, 'r');
2327	}
2328	if (mg) {
2329	re = (regexp *)mg->mg_obj;
2330	(void)ReREFCNT_inc(re);
2331	}
2332	else {
2333	STRLEN len;
2334	char *t = SvPV(ret, len);
2335	PMOP pm;
2336	char *oprecomp = PL_regprecomp;
2337	I32 osize = PL_regsize;
2338	I32 onpar = PL_regnpar;
2339
2340	pm.op_pmflags = 0;
2341	pm.op_pmdynflags = (UTF\|\|DO_UTF8(ret) ? PMdf_UTF8 : 0);
2342	re = CALLREGCOMP(aTHX_ t, t + len, &pm);
2343	if (!(SvFLAGS(ret)
2344	& (SVs_TEMP \| SVs_PADTMP \| SVf_READONLY)))
2345	sv_magic(ret,(SV*)ReREFCNT_inc(re),'r',0,0);
2346	PL_regprecomp = oprecomp;
2347	PL_regsize = osize;
2348	PL_regnpar = onpar;
2349	}
2350	DEBUG_r(
2351	PerlIO_printf(Perl_debug_log,
2352	"Entering embedded `%s%.60s%s%s'\n",
2353	PL_colors[0],
2354	re->precomp,
2355	PL_colors[1],
2356	(strlen(re->precomp) > 60 ? "..." : ""))
2357	);
2358	state.node = next;
2359	state.prev = PL_reg_call_cc;
2360	state.cc = PL_regcc;
2361	state.re = PL_reg_re;
2362
2363	PL_regcc = 0;
2364
2365	cp = regcppush(0); /* Save all the positions. */
2366	REGCP_SET;
2367	cache_re(re);
2368	state.ss = PL_savestack_ix;
2369	*PL_reglastparen = 0;
2370	PL_reg_call_cc = &state;
2371	PL_reginput = locinput;
2372
2373	/* XXXX This is too dramatic a measure... */
2374	PL_reg_maxiter = 0;
2375
2376	if (regmatch(re->program + 1)) {
2377	/* Even though we succeeded, we need to restore
2378	global variables, since we may be wrapped inside
2379	SUSPEND, thus the match may be not finished yet. */
2380
2381	/* XXXX Do this only if SUSPENDed? */
2382	PL_reg_call_cc = state.prev;
2383	PL_regcc = state.cc;
2384	PL_reg_re = state.re;
2385	cache_re(PL_reg_re);
2386
2387	/* XXXX This is too dramatic a measure... */
2388	PL_reg_maxiter = 0;
2389
2390	/* These are needed even if not SUSPEND. */
2391	ReREFCNT_dec(re);
2392	regcpblow(cp);
2393	sayYES;
2394	}
2395	ReREFCNT_dec(re);
2396	REGCP_UNWIND;
2397	regcppop();
2398	PL_reg_call_cc = state.prev;
2399	PL_regcc = state.cc;
2400	PL_reg_re = state.re;
2401	cache_re(PL_reg_re);
2402
2403	/* XXXX This is too dramatic a measure... */
2404	PL_reg_maxiter = 0;
2405
2406	sayNO;
2407	}
2408	sw = SvTRUE(ret);
2409	logical = 0;
2410	}
2411	else
2412	sv_setsv(save_scalar(PL_replgv), ret);
2413	break;
2414	}
2415	case OPEN:
2416	n = ARG(scan); /* which paren pair */
2417	PL_reg_start_tmp[n] = locinput;
2418	if (n > PL_regsize)
2419	PL_regsize = n;
2420	break;
2421	case CLOSE:
2422	n = ARG(scan); /* which paren pair */
2423	PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr;
2424	PL_regendp[n] = locinput - PL_bostr;
2425	if (n > *PL_reglastparen)
2426	*PL_reglastparen = n;
2427	break;
2428	case GROUPP:
2429	n = ARG(scan); /* which paren pair */
2430	sw = (*PL_reglastparen >= n && PL_regendp[n] != -1);
2431	break;
2432	case IFTHEN:
2433	PL_reg_leftiter = PL_reg_maxiter; /* Void cache */
2434	if (sw)
2435	next = NEXTOPER(NEXTOPER(scan));
2436	else {
2437	next = scan + ARG(scan);
2438	if (OP(next) == IFTHEN) /* Fake one. */
2439	next = NEXTOPER(NEXTOPER(next));
2440	}
2441	break;
2442	case LOGICAL:
2443	logical = scan->flags;
2444	break;
2445	/*******************************************************************
2446	PL_regcc contains infoblock about the innermost (...)* loop, and
2447	a pointer to the next outer infoblock.
2448
2449	Here is how Y(A)*Z is processed (if it is compiled into CURLYX/WHILEM):
2450
2451	1) After matching X, regnode for CURLYX is processed;
2452
2453	2) This regnode creates infoblock on the stack, and calls
2454	regmatch() recursively with the starting point at WHILEM node;
2455
2456	3) Each hit of WHILEM node tries to match A and Z (in the order
2457	depending on the current iteration, min/max of {min,max} and
2458	greediness). The information about where are nodes for "A"
2459	and "Z" is read from the infoblock, as is info on how many times "A"
2460	was already matched, and greediness.
2461
2462	4) After A matches, the same WHILEM node is hit again.
2463
2464	5) Each time WHILEM is hit, PL_regcc is the infoblock created by CURLYX
2465	of the same pair. Thus when WHILEM tries to match Z, it temporarily
2466	resets PL_regcc, since this Y(A)*Z can be a part of some other loop:
2467	as in (Y(A)Z). If Z matches, the automaton will hit the WHILEM node
2468	of the external loop.
2469
2470	Currently present infoblocks form a tree with a stem formed by PL_curcc
2471	and whatever it mentions via ->next, and additional attached trees
2472	corresponding to temporarily unset infoblocks as in "5" above.
2473
2474	In the following picture infoblocks for outer loop of
2475	(Y(A)?Z)?T are denoted O, for inner I. NULL starting block
2476	is denoted by x. The matched string is YAAZYAZT. Temporarily postponed
2477	infoblocks are drawn below the "reset" infoblock.
2478
2479	In fact in the picture below we do not show failed matches for Z and T
2480	by WHILEM blocks. [We illustrate minimal matches, since for them it is
2481	more obvious why one needs to temporary unset infoblocks.]
2482
2483	Matched REx position InfoBlocks Comment
2484	(Y(A)?Z)?T x
2485	Y(A)?Z)?T x <- O
2486	Y (A)?Z)?T x <- O
2487	Y A)?Z)?T x <- O <- I
2488	YA )?Z)?T x <- O <- I
2489	YA A)?Z)?T x <- O <- I
2490	YAA )?Z)?T x <- O <- I
2491	YAA Z)*?T x <- O # Temporary unset I
2492	I
2493
2494	YAAZ Y(A)?Z)?T x <- O
2495	I
2496
2497	YAAZY (A)?Z)?T x <- O
2498	I
2499
2500	YAAZY A)?Z)?T x <- O <- I
2501	I
2502
2503	YAAZYA )?Z)?T x <- O <- I
2504	I
2505
2506	YAAZYA Z)*?T x <- O # Temporary unset I
2507	I,I
2508
2509	YAAZYAZ )*?T x <- O
2510	I,I
2511
2512	YAAZYAZ T x # Temporary unset O
2513	O
2514	I,I
2515
2516	YAAZYAZT x
2517	O
2518	I,I
2519	*******************************************************************/
2520	case CURLYX: {
2521	CURCUR cc;
2522	CHECKPOINT cp = PL_savestack_ix;
2523
2524	if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
2525	next += ARG(next);
2526	cc.oldcc = PL_regcc;
2527	PL_regcc = &cc;
2528	cc.parenfloor = *PL_reglastparen;
2529	cc.cur = -1;
2530	cc.min = ARG1(scan);
2531	cc.max = ARG2(scan);
2532	cc.scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
2533	cc.next = next;
2534	cc.minmod = minmod;
2535	cc.lastloc = 0;
2536	PL_reginput = locinput;
2537	n = regmatch(PREVOPER(next)); /* start on the WHILEM */
2538	regcpblow(cp);
2539	PL_regcc = cc.oldcc;
2540	saySAME(n);
2541	}
2542	/* NOT REACHED */
2543	case WHILEM: {
2544	/*
2545	* This is really hard to understand, because after we match
2546	* what we're trying to match, we must make sure the rest of
2547	* the REx is going to match for sure, and to do that we have
2548	* to go back UP the parse tree by recursing ever deeper. And
2549	* if it fails, we have to reset our parent's current state
2550	* that we can try again after backing off.
2551	*/
2552
2553	CHECKPOINT cp, lastcp;
2554	CURCUR* cc = PL_regcc;
2555	char lastloc = cc->lastloc; / Detection of 0-len. */
2556
2557	n = cc->cur + 1; /* how many we know we matched */
2558	PL_reginput = locinput;
2559
2560	DEBUG_r(
2561	PerlIO_printf(Perl_debug_log,
2562	"%*s %ld out of %ld..%ld cc=%lx\n",
2563	REPORT_CODE_OFF+PL_regindent*2, "",
2564	(long)n, (long)cc->min,
2565	(long)cc->max, (long)cc)
2566	);
2567
2568	/* If degenerate scan matches "", assume scan done. */
2569
2570	if (locinput == cc->lastloc && n >= cc->min) {
2571	PL_regcc = cc->oldcc;
2572	if (PL_regcc)
2573	ln = PL_regcc->cur;
2574	DEBUG_r(
2575	PerlIO_printf(Perl_debug_log,
2576	"%*s empty match detected, try continuation...\n",
2577	REPORT_CODE_OFF+PL_regindent*2, "")
2578	);
2579	if (regmatch(cc->next))
2580	sayYES;
2581	if (PL_regcc)
2582	PL_regcc->cur = ln;
2583	PL_regcc = cc;
2584	sayNO;
2585	}
2586
2587	/* First just match a string of min scans. */
2588
2589	if (n < cc->min) {
2590	cc->cur = n;
2591	cc->lastloc = locinput;
2592	if (regmatch(cc->scan))
2593	sayYES;
2594	cc->cur = n - 1;
2595	cc->lastloc = lastloc;
2596	sayNO;
2597	}
2598
2599	if (scan->flags) {
2600	/* Check whether we already were at this position.
2601	Postpone detection until we know the match is not
2602	that much linear. */
2603	if (!PL_reg_maxiter) {
2604	PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
2605	PL_reg_leftiter = PL_reg_maxiter;
2606	}
2607	if (PL_reg_leftiter-- == 0) {
2608	I32 size = (PL_reg_maxiter + 7)/8;
2609	if (PL_reg_poscache) {
2610	if (PL_reg_poscache_size < size) {
2611	Renew(PL_reg_poscache, size, char);
2612	PL_reg_poscache_size = size;
2613	}
2614	Zero(PL_reg_poscache, size, char);
2615	}
2616	else {
2617	PL_reg_poscache_size = size;
2618	Newz(29, PL_reg_poscache, size, char);
2619	}
2620	DEBUG_r(
2621	PerlIO_printf(Perl_debug_log,
2622	"%sDetected a super-linear match, switching on caching%s...\n",
2623	PL_colors[4], PL_colors[5])
2624	);
2625	}
2626	if (PL_reg_leftiter < 0) {
2627	I32 o = locinput - PL_bostr, b;
2628
2629	o = (scan->flags & 0xf) - 1 + o * (scan->flags>>4);
2630	b = o % 8;
2631	o /= 8;
2632	if (PL_reg_poscache[o] & (1<<b)) {
2633	DEBUG_r(
2634	PerlIO_printf(Perl_debug_log,
2635	"%*s already tried at this position...\n",
2636	REPORT_CODE_OFF+PL_regindent*2, "")
2637	);
2638	sayNO_SILENT;
2639	}
2640	PL_reg_poscache[o] \|= (1<<b);
2641	}
2642	}
2643
2644	/* Prefer next over scan for minimal matching. */
2645
2646	if (cc->minmod) {
2647	PL_regcc = cc->oldcc;
2648	if (PL_regcc)
2649	ln = PL_regcc->cur;
2650	cp = regcppush(cc->parenfloor);
2651	REGCP_SET;
2652	if (regmatch(cc->next)) {
2653	regcpblow(cp);
2654	sayYES; /* All done. */
2655	}
2656	REGCP_UNWIND;
2657	regcppop();
2658	if (PL_regcc)
2659	PL_regcc->cur = ln;
2660	PL_regcc = cc;
2661
2662	if (n >= cc->max) { /* Maximum greed exceeded? */
2663	if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
2664	&& !(PL_reg_flags & RF_warned)) {
2665	PL_reg_flags \|= RF_warned;
2666	Perl_warner(aTHX_ WARN_REGEXP, "%s limit (%d) exceeded",
2667	"Complex regular subexpression recursion",
2668	REG_INFTY - 1);
2669	}
2670	sayNO;
2671	}
2672
2673	DEBUG_r(
2674	PerlIO_printf(Perl_debug_log,
2675	"%*s trying longer...\n",
2676	REPORT_CODE_OFF+PL_regindent*2, "")
2677	);
2678	/* Try scanning more and see if it helps. */
2679	PL_reginput = locinput;
2680	cc->cur = n;
2681	cc->lastloc = locinput;
2682	cp = regcppush(cc->parenfloor);
2683	REGCP_SET;
2684	if (regmatch(cc->scan)) {
2685	regcpblow(cp);
2686	sayYES;
2687	}
2688	REGCP_UNWIND;
2689	regcppop();
2690	cc->cur = n - 1;
2691	cc->lastloc = lastloc;
2692	sayNO;
2693	}
2694
2695	/* Prefer scan over next for maximal matching. */
2696
2697	if (n < cc->max) { /* More greed allowed? */
2698	cp = regcppush(cc->parenfloor);
2699	cc->cur = n;
2700	cc->lastloc = locinput;
2701	REGCP_SET;
2702	if (regmatch(cc->scan)) {
2703	regcpblow(cp);
2704	sayYES;
2705	}
2706	REGCP_UNWIND;
2707	regcppop(); /* Restore some previous $<digit>s? */
2708	PL_reginput = locinput;
2709	DEBUG_r(
2710	PerlIO_printf(Perl_debug_log,
2711	"%*s failed, try continuation...\n",
2712	REPORT_CODE_OFF+PL_regindent*2, "")
2713	);
2714	}
2715	if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
2716	&& !(PL_reg_flags & RF_warned)) {
2717	PL_reg_flags \|= RF_warned;
2718	Perl_warner(aTHX_ WARN_REGEXP, "%s limit (%d) exceeded",
2719	"Complex regular subexpression recursion",
2720	REG_INFTY - 1);
2721	}
2722
2723	/* Failed deeper matches of scan, so see if this one works. */
2724	PL_regcc = cc->oldcc;
2725	if (PL_regcc)
2726	ln = PL_regcc->cur;
2727	if (regmatch(cc->next))
2728	sayYES;
2729	if (PL_regcc)
2730	PL_regcc->cur = ln;
2731	PL_regcc = cc;
2732	cc->cur = n - 1;
2733	cc->lastloc = lastloc;
2734	sayNO;
2735	}
2736	/* NOT REACHED */
2737	case BRANCHJ:
2738	next = scan + ARG(scan);
2739	if (next == scan)
2740	next = NULL;
2741	inner = NEXTOPER(NEXTOPER(scan));
2742	goto do_branch;
2743	case BRANCH:
2744	inner = NEXTOPER(scan);
2745	do_branch:
2746	{
2747	CHECKPOINT lastcp;
2748	c1 = OP(scan);
2749	if (OP(next) != c1) /* No choice. */
2750	next = inner; /* Avoid recursion. */
2751	else {
2752	int lastparen = *PL_reglastparen;
2753
2754	REGCP_SET;
2755	do {
2756	PL_reginput = locinput;
2757	if (regmatch(inner))
2758	sayYES;
2759	REGCP_UNWIND;
2760	for (n = *PL_reglastparen; n > lastparen; n--)
2761	PL_regendp[n] = -1;
2762	*PL_reglastparen = n;
2763	scan = next;
2764	/SUPPRESS 560/
2765	if ((n = (c1 == BRANCH ? NEXT_OFF(next) : ARG(next))))
2766	next += n;
2767	else
2768	next = NULL;
2769	inner = NEXTOPER(scan);
2770	if (c1 == BRANCHJ) {
2771	inner = NEXTOPER(inner);
2772	}
2773	} while (scan != NULL && OP(scan) == c1);
2774	sayNO;
2775	/* NOTREACHED */
2776	}
2777	}
2778	break;
2779	case MINMOD:
2780	minmod = 1;
2781	break;
2782	case CURLYM:
2783	{
2784	I32 l = 0;
2785	CHECKPOINT lastcp;
2786
2787	/* We suppose that the next guy does not need
2788	backtracking: in particular, it is of constant length,
2789	and has no parenths to influence future backrefs. */
2790	ln = ARG1(scan); /* min to match */
2791	n = ARG2(scan); /* max to match */
2792	paren = scan->flags;
2793	if (paren) {
2794	if (paren > PL_regsize)
2795	PL_regsize = paren;
2796	if (paren > *PL_reglastparen)
2797	*PL_reglastparen = paren;
2798	}
2799	scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
2800	if (paren)
2801	scan += NEXT_OFF(scan); /* Skip former OPEN. */
2802	PL_reginput = locinput;
2803	if (minmod) {
2804	minmod = 0;
2805	if (ln && regrepeat_hard(scan, ln, &l) < ln)
2806	sayNO;
2807	if (ln && l == 0 && n >= ln
2808	/* In fact, this is tricky. If paren, then the
2809	fact that we did/didnot match may influence
2810	future execution. */
2811	&& !(paren && ln == 0))
2812	ln = n;
2813	locinput = PL_reginput;
2814	if (PL_regkind[(U8)OP(next)] == EXACT) {
2815	c1 = (U8)*STRING(next);
2816	if (OP(next) == EXACTF)
2817	c2 = PL_fold[c1];
2818	else if (OP(next) == EXACTFL)
2819	c2 = PL_fold_locale[c1];
2820	else
2821	c2 = c1;
2822	}
2823	else
2824	c1 = c2 = -1000;
2825	REGCP_SET;
2826	/* This may be improved if l == 0. */
2827	while (n >= ln \|\| (n == REG_INFTY && ln > 0 && l)) { /* ln overflow ? */
2828	/* If it could work, try it. */
2829	if (c1 == -1000 \|\|
2830	UCHARAT(PL_reginput) == c1 \|\|
2831	UCHARAT(PL_reginput) == c2)
2832	{
2833	if (paren) {
2834	if (n) {
2835	PL_regstartp[paren] =
2836	HOPc(PL_reginput, -l) - PL_bostr;
2837	PL_regendp[paren] = PL_reginput - PL_bostr;
2838	}
2839	else
2840	PL_regendp[paren] = -1;
2841	}
2842	if (regmatch(next))
2843	sayYES;
2844	REGCP_UNWIND;
2845	}
2846	/* Couldn't or didn't -- move forward. */
2847	PL_reginput = locinput;
2848	if (regrepeat_hard(scan, 1, &l)) {
2849	ln++;
2850	locinput = PL_reginput;
2851	}
2852	else
2853	sayNO;
2854	}
2855	}
2856	else {
2857	n = regrepeat_hard(scan, n, &l);
2858	if (n != 0 && l == 0
2859	/* In fact, this is tricky. If paren, then the
2860	fact that we did/didnot match may influence
2861	future execution. */
2862	&& !(paren && ln == 0))
2863	ln = n;
2864	locinput = PL_reginput;
2865	DEBUG_r(
2866	PerlIO_printf(Perl_debug_log,
2867	"%*s matched %"IVdf" times, len=%"IVdf"...\n",
2868	(int)(REPORT_CODE_OFF+PL_regindent*2), "",
2869	(IV) n, (IV)l)
2870	);
2871	if (n >= ln) {
2872	if (PL_regkind[(U8)OP(next)] == EXACT) {
2873	c1 = (U8)*STRING(next);
2874	if (OP(next) == EXACTF)
2875	c2 = PL_fold[c1];
2876	else if (OP(next) == EXACTFL)
2877	c2 = PL_fold_locale[c1];
2878	else
2879	c2 = c1;
2880	}
2881	else
2882	c1 = c2 = -1000;
2883	}
2884	REGCP_SET;
2885	while (n >= ln) {
2886	/* If it could work, try it. */
2887	if (c1 == -1000 \|\|
2888	UCHARAT(PL_reginput) == c1 \|\|
2889	UCHARAT(PL_reginput) == c2)
2890	{
2891	DEBUG_r(
2892	PerlIO_printf(Perl_debug_log,
2893	"%*s trying tail with n=%"IVdf"...\n",
2894	(int)(REPORT_CODE_OFF+PL_regindent*2), "", (IV)n)
2895	);
2896	if (paren) {
2897	if (n) {
2898	PL_regstartp[paren] = HOPc(PL_reginput, -l) - PL_bostr;
2899	PL_regendp[paren] = PL_reginput - PL_bostr;
2900	}
2901	else
2902	PL_regendp[paren] = -1;
2903	}
2904	if (regmatch(next))
2905	sayYES;
2906	REGCP_UNWIND;
2907	}
2908	/* Couldn't or didn't -- back up. */
2909	n--;
2910	locinput = HOPc(locinput, -l);
2911	PL_reginput = locinput;
2912	}
2913	}
2914	sayNO;
2915	break;
2916	}
2917	case CURLYN:
2918	paren = scan->flags; /* Which paren to set */
2919	if (paren > PL_regsize)
2920	PL_regsize = paren;
2921	if (paren > *PL_reglastparen)
2922	*PL_reglastparen = paren;
2923	ln = ARG1(scan); /* min to match */
2924	n = ARG2(scan); /* max to match */
2925	scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
2926	goto repeat;
2927	case CURLY:
2928	paren = 0;
2929	ln = ARG1(scan); /* min to match */
2930	n = ARG2(scan); /* max to match */
2931	scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
2932	goto repeat;
2933	case STAR:
2934	ln = 0;
2935	n = REG_INFTY;
2936	scan = NEXTOPER(scan);
2937	paren = 0;
2938	goto repeat;
2939	case PLUS:
2940	ln = 1;
2941	n = REG_INFTY;
2942	scan = NEXTOPER(scan);
2943	paren = 0;
2944	repeat:
2945	/*
2946	* Lookahead to avoid useless match attempts
2947	* when we know what character comes next.
2948	*/
2949	if (PL_regkind[(U8)OP(next)] == EXACT) {
2950	c1 = (U8)*STRING(next);
2951	if (OP(next) == EXACTF)
2952	c2 = PL_fold[c1];
2953	else if (OP(next) == EXACTFL)
2954	c2 = PL_fold_locale[c1];
2955	else
2956	c2 = c1;
2957	}
2958	else
2959	c1 = c2 = -1000;
2960	PL_reginput = locinput;
2961	if (minmod) {
2962	CHECKPOINT lastcp;
2963	minmod = 0;
2964	if (ln && regrepeat(scan, ln) < ln)
2965	sayNO;
2966	locinput = PL_reginput;
2967	REGCP_SET;
2968	if (c1 != -1000) {
2969	char e = locinput + n - ln; / Should not check after this */
2970	char *old = locinput;
2971
2972	if (e >= PL_regeol \|\| (n == REG_INFTY))
2973	e = PL_regeol - 1;
2974	while (1) {
2975	/* Find place 'next' could work */
2976	if (c1 == c2) {
2977	while (locinput <= e && *locinput != c1)
2978	locinput++;
2979	} else {
2980	while (locinput <= e
2981	&& *locinput != c1
2982	&& *locinput != c2)
2983	locinput++;
2984	}
2985	if (locinput > e)
2986	sayNO;
2987	/* PL_reginput == old now */
2988	if (locinput != old) {
2989	ln = 1; /* Did some */
2990	if (regrepeat(scan, locinput - old) <
2991	locinput - old)
2992	sayNO;
2993	}
2994	/* PL_reginput == locinput now */
2995	if (paren) {
2996	if (ln) {
2997	PL_regstartp[paren] = HOPc(locinput, -1) - PL_bostr;
2998	PL_regendp[paren] = locinput - PL_bostr;
2999	}
3000	else
3001	PL_regendp[paren] = -1;
3002	}
3003	if (regmatch(next))
3004	sayYES;
3005	PL_reginput = locinput; /* Could be reset... */
3006	REGCP_UNWIND;
3007	/* Couldn't or didn't -- move forward. */
3008	old = locinput++;
3009	}
3010	}
3011	else
3012	while (n >= ln \|\| (n == REG_INFTY && ln > 0)) { /* ln overflow ? */
3013	/* If it could work, try it. */
3014	if (c1 == -1000 \|\|
3015	UCHARAT(PL_reginput) == c1 \|\|
3016	UCHARAT(PL_reginput) == c2)
3017	{
3018	if (paren) {
3019	if (n) {
3020	PL_regstartp[paren] = HOPc(PL_reginput, -1) - PL_bostr;
3021	PL_regendp[paren] = PL_reginput - PL_bostr;
3022	}
3023	else
3024	PL_regendp[paren] = -1;
3025	}
3026	if (regmatch(next))
3027	sayYES;
3028	REGCP_UNWIND;
3029	}
3030	/* Couldn't or didn't -- move forward. */
3031	PL_reginput = locinput;
3032	if (regrepeat(scan, 1)) {
3033	ln++;
3034	locinput = PL_reginput;
3035	}
3036	else
3037	sayNO;
3038	}
3039	}
3040	else {
3041	CHECKPOINT lastcp;
3042	n = regrepeat(scan, n);
3043	locinput = PL_reginput;
3044	if (ln < n && PL_regkind[(U8)OP(next)] == EOL &&
3045	(!PL_multiline \|\| OP(next) == SEOL \|\| OP(next) == EOS)) {
3046	ln = n; /* why back off? */
3047	/* ...because $ and \Z can match before and after
3048	newline at the end. Consider "\n\n" =~ /\n+\Z\n/.
3049	We should back off by one in this case. */
3050	if (UCHARAT(PL_reginput - 1) == '\n' && OP(next) != EOS)
3051	ln--;
3052	}
3053	REGCP_SET;
3054	if (paren) {
3055	while (n >= ln) {
3056	/* If it could work, try it. */
3057	if (c1 == -1000 \|\|
3058	UCHARAT(PL_reginput) == c1 \|\|
3059	UCHARAT(PL_reginput) == c2)
3060	{
3061	if (paren && n) {
3062	if (n) {
3063	PL_regstartp[paren] = HOPc(PL_reginput, -1) - PL_bostr;
3064	PL_regendp[paren] = PL_reginput - PL_bostr;
3065	}
3066	else
3067	PL_regendp[paren] = -1;
3068	}
3069	if (regmatch(next))
3070	sayYES;
3071	REGCP_UNWIND;
3072	}
3073	/* Couldn't or didn't -- back up. */
3074	n--;
3075	PL_reginput = locinput = HOPc(locinput, -1);
3076	}
3077	}
3078	else {
3079	while (n >= ln) {
3080	/* If it could work, try it. */
3081	if (c1 == -1000 \|\|
3082	UCHARAT(PL_reginput) == c1 \|\|
3083	UCHARAT(PL_reginput) == c2)
3084	{
3085	if (regmatch(next))
3086	sayYES;
3087	REGCP_UNWIND;
3088	}
3089	/* Couldn't or didn't -- back up. */
3090	n--;
3091	PL_reginput = locinput = HOPc(locinput, -1);
3092	}
3093	}
3094	}
3095	sayNO;
3096	break;
3097	case END:
3098	if (PL_reg_call_cc) {
3099	re_cc_state *cur_call_cc = PL_reg_call_cc;
3100	CURCUR *cctmp = PL_regcc;
3101	regexp *re = PL_reg_re;
3102	CHECKPOINT cp, lastcp;
3103
3104	cp = regcppush(0); /* Save all the positions. */
3105	REGCP_SET;
3106	regcp_set_to(PL_reg_call_cc->ss); /* Restore parens of
3107	the caller. */
3108	PL_reginput = locinput; /* Make position available to
3109	the callcc. */
3110	cache_re(PL_reg_call_cc->re);
3111	PL_regcc = PL_reg_call_cc->cc;
3112	PL_reg_call_cc = PL_reg_call_cc->prev;
3113	if (regmatch(cur_call_cc->node)) {
3114	PL_reg_call_cc = cur_call_cc;
3115	regcpblow(cp);
3116	sayYES;
3117	}
3118	REGCP_UNWIND;
3119	regcppop();
3120	PL_reg_call_cc = cur_call_cc;
3121	PL_regcc = cctmp;
3122	PL_reg_re = re;
3123	cache_re(re);
3124
3125	DEBUG_r(
3126	PerlIO_printf(Perl_debug_log,
3127	"%*s continuation failed...\n",
3128	REPORT_CODE_OFF+PL_regindent*2, "")
3129	);
3130	sayNO_SILENT;
3131	}
3132	if (locinput < PL_regtill) {
3133	DEBUG_r(PerlIO_printf(Perl_debug_log,
3134	"%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
3135	PL_colors[4],
3136	(long)(locinput - PL_reg_starttry),
3137	(long)(PL_regtill - PL_reg_starttry),
3138	PL_colors[5]));
3139	sayNO_FINAL; /* Cannot match: too short. */
3140	}
3141	PL_reginput = locinput; /* put where regtry can find it */
3142	sayYES_FINAL; /* Success! */
3143	case SUCCEED:
3144	PL_reginput = locinput; /* put where regtry can find it */
3145	sayYES_LOUD; /* Success! */
3146	case SUSPEND:
3147	n = 1;
3148	PL_reginput = locinput;
3149	goto do_ifmatch;
3150	case UNLESSM:
3151	n = 0;
3152	if (scan->flags) {
3153	if (UTF) { /* XXXX This is absolutely
3154	broken, we read before
3155	start of string. */
3156	s = HOPMAYBEc(locinput, -scan->flags);
3157	if (!s)
3158	goto say_yes;
3159	PL_reginput = s;
3160	}
3161	else {
3162	if (locinput < PL_bostr + scan->flags)
3163	goto say_yes;
3164	PL_reginput = locinput - scan->flags;
3165	goto do_ifmatch;
3166	}
3167	}
3168	else
3169	PL_reginput = locinput;
3170	goto do_ifmatch;
3171	case IFMATCH:
3172	n = 1;
3173	if (scan->flags) {
3174	if (UTF) { /* XXXX This is absolutely
3175	broken, we read before
3176	start of string. */
3177	s = HOPMAYBEc(locinput, -scan->flags);
3178	if (!s \|\| s < PL_bostr)
3179	goto say_no;
3180	PL_reginput = s;
3181	}
3182	else {
3183	if (locinput < PL_bostr + scan->flags)
3184	goto say_no;
3185	PL_reginput = locinput - scan->flags;
3186	goto do_ifmatch;
3187	}
3188	}
3189	else
3190	PL_reginput = locinput;
3191
3192	do_ifmatch:
3193	inner = NEXTOPER(NEXTOPER(scan));
3194	if (regmatch(inner) != n) {
3195	say_no:
3196	if (logical) {
3197	logical = 0;
3198	sw = 0;
3199	goto do_longjump;
3200	}
3201	else
3202	sayNO;
3203	}
3204	say_yes:
3205	if (logical) {
3206	logical = 0;
3207	sw = 1;
3208	}
3209	if (OP(scan) == SUSPEND) {
3210	locinput = PL_reginput;
3211	nextchr = UCHARAT(locinput);
3212	}
3213	/* FALL THROUGH. */
3214	case LONGJMP:
3215	do_longjump:
3216	next = scan + ARG(scan);
3217	if (next == scan)
3218	next = NULL;
3219	break;
3220	default:
3221	PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
3222	PTR2UV(scan), OP(scan));
3223	Perl_croak(aTHX_ "regexp memory corruption");
3224	}
3225	scan = next;
3226	}
3227
3228	/*
3229	* We get here only if there's trouble -- normally "case END" is
3230	* the terminating point.
3231	*/
3232	Perl_croak(aTHX_ "corrupted regexp pointers");
3233	/NOTREACHED/
3234	sayNO;
3235
3236	yes_loud:
3237	DEBUG_r(
3238	PerlIO_printf(Perl_debug_log,
3239	"%*s %scould match...%s\n",
3240	REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],PL_colors[5])
3241	);
3242	goto yes;
3243	yes_final:
3244	DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
3245	PL_colors[4],PL_colors[5]));
3246	yes:
3247	#ifdef DEBUGGING
3248	PL_regindent--;
3249	#endif
3250	return 1;
3251
3252	no:
3253	DEBUG_r(
3254	PerlIO_printf(Perl_debug_log,
3255	"%*s %sfailed...%s\n",
3256	REPORT_CODE_OFF+PL_regindent*2, "",PL_colors[4],PL_colors[5])
3257	);
3258	goto do_no;
3259	no_final:
3260	do_no:
3261	#ifdef DEBUGGING
3262	PL_regindent--;
3263	#endif
3264	return 0;
3265	}
3266
3267	/*
3268	- regrepeat - repeatedly match something simple, report how many
3269	*/
3270	/*
3271	* [This routine now assumes that it will only match on things of length 1.
3272	* That was true before, but now we assume scan - reginput is the count,
3273	* rather than incrementing count on every character. [Er, except utf8.]]
3274	*/
3275	STATIC I32
3276	S_regrepeat(pTHX_ regnode *p, I32 max)
3277	{
3278	dTHR;
3279	register char *scan;
3280	register I32 c;
3281	register char *loceol = PL_regeol;
3282	register I32 hardcount = 0;
3283
3284	scan = PL_reginput;
3285	if (max != REG_INFTY && max < loceol - scan)
3286	loceol = scan + max;
3287	switch (OP(p)) {
3288	case REG_ANY:
3289	while (scan < loceol && *scan != '\n')
3290	scan++;
3291	break;
3292	case SANY:
3293	scan = loceol;
3294	break;
3295	case ANYUTF8:
3296	loceol = PL_regeol;
3297	while (scan < loceol && *scan != '\n') {
3298	scan += UTF8SKIP(scan);
3299	hardcount++;
3300	}
3301	break;
3302	case SANYUTF8:
3303	loceol = PL_regeol;
3304	while (scan < loceol) {
3305	scan += UTF8SKIP(scan);
3306	hardcount++;
3307	}
3308	break;
3309	case EXACT: /* length of string is 1 */
3310	c = (U8)*STRING(p);
3311	while (scan < loceol && UCHARAT(scan) == c)
3312	scan++;
3313	break;
3314	case EXACTF: /* length of string is 1 */
3315	c = (U8)*STRING(p);
3316	while (scan < loceol &&
3317	(UCHARAT(scan) == c \|\| UCHARAT(scan) == PL_fold[c]))
3318	scan++;
3319	break;
3320	case EXACTFL: /* length of string is 1 */
3321	PL_reg_flags \|= RF_tainted;
3322	c = (U8)*STRING(p);
3323	while (scan < loceol &&
3324	(UCHARAT(scan) == c \|\| UCHARAT(scan) == PL_fold_locale[c]))
3325	scan++;
3326	break;
3327	case ANYOFUTF8:
3328	loceol = PL_regeol;
3329	while (scan < loceol && REGINCLASSUTF8(p, (U8*)scan)) {
3330	scan += UTF8SKIP(scan);
3331	hardcount++;
3332	}
3333	break;
3334	case ANYOF:
3335	while (scan < loceol && REGINCLASS(p, *scan))
3336	scan++;
3337	break;
3338	case ALNUM:
3339	while (scan < loceol && isALNUM(*scan))
3340	scan++;
3341	break;
3342	case ALNUMUTF8:
3343	loceol = PL_regeol;
3344	while (scan < loceol && swash_fetch(PL_utf8_alnum, (U8*)scan)) {
3345	scan += UTF8SKIP(scan);
3346	hardcount++;
3347	}
3348	break;
3349	case ALNUML:
3350	PL_reg_flags \|= RF_tainted;
3351	while (scan < loceol && isALNUM_LC(*scan))
3352	scan++;
3353	break;
3354	case ALNUMLUTF8:
3355	PL_reg_flags \|= RF_tainted;
3356	loceol = PL_regeol;
3357	while (scan < loceol && isALNUM_LC_utf8((U8*)scan)) {
3358	scan += UTF8SKIP(scan);
3359	hardcount++;
3360	}
3361	break;
3362	break;
3363	case NALNUM:
3364	while (scan < loceol && !isALNUM(*scan))
3365	scan++;
3366	break;
3367	case NALNUMUTF8:
3368	loceol = PL_regeol;
3369	while (scan < loceol && !swash_fetch(PL_utf8_alnum, (U8*)scan)) {
3370	scan += UTF8SKIP(scan);
3371	hardcount++;
3372	}
3373	break;
3374	case NALNUML:
3375	PL_reg_flags \|= RF_tainted;
3376	while (scan < loceol && !isALNUM_LC(*scan))
3377	scan++;
3378	break;
3379	case NALNUMLUTF8:
3380	PL_reg_flags \|= RF_tainted;
3381	loceol = PL_regeol;
3382	while (scan < loceol && !isALNUM_LC_utf8((U8*)scan)) {
3383	scan += UTF8SKIP(scan);
3384	hardcount++;
3385	}
3386	break;
3387	case SPACE:
3388	while (scan < loceol && isSPACE(*scan))
3389	scan++;
3390	break;
3391	case SPACEUTF8:
3392	loceol = PL_regeol;
3393	while (scan < loceol && (scan == ' ' \|\| swash_fetch(PL_utf8_space,(U8)scan))) {
3394	scan += UTF8SKIP(scan);
3395	hardcount++;
3396	}
3397	break;
3398	case SPACEL:
3399	PL_reg_flags \|= RF_tainted;
3400	while (scan < loceol && isSPACE_LC(*scan))
3401	scan++;
3402	break;
3403	case SPACELUTF8:
3404	PL_reg_flags \|= RF_tainted;
3405	loceol = PL_regeol;
3406	while (scan < loceol && (scan == ' ' \|\| isSPACE_LC_utf8((U8)scan))) {
3407	scan += UTF8SKIP(scan);
3408	hardcount++;
3409	}
3410	break;
3411	case NSPACE:
3412	while (scan < loceol && !isSPACE(*scan))
3413	scan++;
3414	break;
3415	case NSPACEUTF8:
3416	loceol = PL_regeol;
3417	while (scan < loceol && !(scan == ' ' \|\| swash_fetch(PL_utf8_space,(U8)scan))) {
3418	scan += UTF8SKIP(scan);
3419	hardcount++;
3420	}
3421	break;
3422	case NSPACEL:
3423	PL_reg_flags \|= RF_tainted;
3424	while (scan < loceol && !isSPACE_LC(*scan))
3425	scan++;
3426	break;
3427	case NSPACELUTF8:
3428	PL_reg_flags \|= RF_tainted;
3429	loceol = PL_regeol;
3430	while (scan < loceol && !(scan == ' ' \|\| isSPACE_LC_utf8((U8)scan))) {
3431	scan += UTF8SKIP(scan);
3432	hardcount++;
3433	}
3434	break;
3435	case DIGIT:
3436	while (scan < loceol && isDIGIT(*scan))
3437	scan++;
3438	break;
3439	case DIGITUTF8:
3440	loceol = PL_regeol;
3441	while (scan < loceol && swash_fetch(PL_utf8_digit,(U8*)scan)) {
3442	scan += UTF8SKIP(scan);
3443	hardcount++;
3444	}
3445	break;
3446	break;
3447	case NDIGIT:
3448	while (scan < loceol && !isDIGIT(*scan))
3449	scan++;
3450	break;
3451	case NDIGITUTF8:
3452	loceol = PL_regeol;
3453	while (scan < loceol && !swash_fetch(PL_utf8_digit,(U8*)scan)) {
3454	scan += UTF8SKIP(scan);
3455	hardcount++;
3456	}
3457	break;
3458	default: /* Called on something of 0 width. */
3459	break; /* So match right here or not at all. */
3460	}
3461
3462	if (hardcount)
3463	c = hardcount;
3464	else
3465	c = scan - PL_reginput;
3466	PL_reginput = scan;
3467
3468	DEBUG_r(
3469	{
3470	SV *prop = sv_newmortal();
3471
3472	regprop(prop, p);
3473	PerlIO_printf(Perl_debug_log,
3474	"%*s %s can match %"IVdf" times out of %"IVdf"...\n",
3475	REPORT_CODE_OFF+1, "", SvPVX(prop),(IV)c,(IV)max);
3476	});
3477
3478	return(c);
3479	}
3480
3481	/*
3482	- regrepeat_hard - repeatedly match something, report total lenth and length
3483	*
3484	* The repeater is supposed to have constant length.
3485	*/
3486
3487	STATIC I32
3488	S_regrepeat_hard(pTHX_ regnode p, I32 max, I32 lp)
3489	{
3490	dTHR;
3491	register char *scan;
3492	register char *start;
3493	register char *loceol = PL_regeol;
3494	I32 l = 0;
3495	I32 count = 0, res = 1;
3496
3497	if (!max)
3498	return 0;
3499
3500	start = PL_reginput;
3501	if (UTF) {
3502	while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) {
3503	if (!count++) {
3504	l = 0;
3505	while (start < PL_reginput) {
3506	l++;
3507	start += UTF8SKIP(start);
3508	}
3509	*lp = l;
3510	if (l == 0)
3511	return max;
3512	}
3513	if (count == max)
3514	return count;
3515	}
3516	}
3517	else {
3518	while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) {
3519	if (!count++) {
3520	*lp = l = PL_reginput - start;
3521	if (max != REG_INFTY && l*max < loceol - scan)
3522	loceol = scan + l*max;
3523	if (l == 0)
3524	return max;
3525	}
3526	}
3527	}
3528	if (!res)
3529	PL_reginput = scan;
3530
3531	return count;
3532	}
3533
3534	/*
3535	- reginclass - determine if a character falls into a character class
3536	*/
3537
3538	STATIC bool
3539	S_reginclass(pTHX_ register regnode *p, register I32 c)
3540	{
3541	dTHR;
3542	char flags = ANYOF_FLAGS(p);
3543	bool match = FALSE;
3544
3545	c &= 0xFF;
3546	if (ANYOF_BITMAP_TEST(p, c))
3547	match = TRUE;
3548	else if (flags & ANYOF_FOLD) {
3549	I32 cf;
3550	if (flags & ANYOF_LOCALE) {
3551	PL_reg_flags \|= RF_tainted;
3552	cf = PL_fold_locale[c];
3553	}
3554	else
3555	cf = PL_fold[c];
3556	if (ANYOF_BITMAP_TEST(p, cf))
3557	match = TRUE;
3558	}
3559
3560	if (!match && (flags & ANYOF_CLASS)) {
3561	PL_reg_flags \|= RF_tainted;
3562	if (
3563	(ANYOF_CLASS_TEST(p, ANYOF_ALNUM) && isALNUM_LC(c)) \|\|
3564	(ANYOF_CLASS_TEST(p, ANYOF_NALNUM) && !isALNUM_LC(c)) \|\|
3565	(ANYOF_CLASS_TEST(p, ANYOF_SPACE) && isSPACE_LC(c)) \|\|
3566	(ANYOF_CLASS_TEST(p, ANYOF_NSPACE) && !isSPACE_LC(c)) \|\|
3567	(ANYOF_CLASS_TEST(p, ANYOF_DIGIT) && isDIGIT_LC(c)) \|\|
3568	(ANYOF_CLASS_TEST(p, ANYOF_NDIGIT) && !isDIGIT_LC(c)) \|\|
3569	(ANYOF_CLASS_TEST(p, ANYOF_ALNUMC) && isALNUMC_LC(c)) \|\|
3570	(ANYOF_CLASS_TEST(p, ANYOF_NALNUMC) && !isALNUMC_LC(c)) \|\|
3571	(ANYOF_CLASS_TEST(p, ANYOF_ALPHA) && isALPHA_LC(c)) \|\|
3572	(ANYOF_CLASS_TEST(p, ANYOF_NALPHA) && !isALPHA_LC(c)) \|\|
3573	(ANYOF_CLASS_TEST(p, ANYOF_ASCII) && isASCII(c)) \|\|
3574	(ANYOF_CLASS_TEST(p, ANYOF_NASCII) && !isASCII(c)) \|\|
3575	(ANYOF_CLASS_TEST(p, ANYOF_CNTRL) && isCNTRL_LC(c)) \|\|
3576	(ANYOF_CLASS_TEST(p, ANYOF_NCNTRL) && !isCNTRL_LC(c)) \|\|
3577	(ANYOF_CLASS_TEST(p, ANYOF_GRAPH) && isGRAPH_LC(c)) \|\|
3578	(ANYOF_CLASS_TEST(p, ANYOF_NGRAPH) && !isGRAPH_LC(c)) \|\|
3579	(ANYOF_CLASS_TEST(p, ANYOF_LOWER) && isLOWER_LC(c)) \|\|
3580	(ANYOF_CLASS_TEST(p, ANYOF_NLOWER) && !isLOWER_LC(c)) \|\|
3581	(ANYOF_CLASS_TEST(p, ANYOF_PRINT) && isPRINT_LC(c)) \|\|
3582	(ANYOF_CLASS_TEST(p, ANYOF_NPRINT) && !isPRINT_LC(c)) \|\|
3583	(ANYOF_CLASS_TEST(p, ANYOF_PUNCT) && isPUNCT_LC(c)) \|\|
3584	(ANYOF_CLASS_TEST(p, ANYOF_NPUNCT) && !isPUNCT_LC(c)) \|\|
3585	(ANYOF_CLASS_TEST(p, ANYOF_UPPER) && isUPPER_LC(c)) \|\|
3586	(ANYOF_CLASS_TEST(p, ANYOF_NUPPER) && !isUPPER_LC(c)) \|\|
3587	(ANYOF_CLASS_TEST(p, ANYOF_XDIGIT) && isXDIGIT(c)) \|\|
3588	(ANYOF_CLASS_TEST(p, ANYOF_NXDIGIT) && !isXDIGIT(c))
3589	) /* How's that for a conditional? */
3590	{
3591	match = TRUE;
3592	}
3593	}
3594
3595	return (flags & ANYOF_INVERT) ? !match : match;
3596	}
3597
3598	STATIC bool
3599	S_reginclassutf8(pTHX_ regnode f, U8 p)
3600	{
3601	dTHR;
3602	char flags = ARG1(f);
3603	bool match = FALSE;
3604	SV sv = (SV)PL_regdata->data[ARG2(f)];
3605
3606	if (swash_fetch(sv, p))
3607	match = TRUE;
3608	else if (flags & ANYOF_FOLD) {
3609	U8 tmpbuf[UTF8_MAXLEN];
3610	if (flags & ANYOF_LOCALE) {
3611	PL_reg_flags \|= RF_tainted;
3612	uv_to_utf8(tmpbuf, toLOWER_LC_utf8(p));
3613	}
3614	else
3615	uv_to_utf8(tmpbuf, toLOWER_utf8(p));
3616	if (swash_fetch(sv, tmpbuf))
3617	match = TRUE;
3618	}
3619
3620	/* UTF8 combined with ANYOF_CLASS is ill-defined. */
3621
3622	return (flags & ANYOF_INVERT) ? !match : match;
3623	}
3624
3625	STATIC U8 *
3626	S_reghop(pTHX_ U8 *s, I32 off)
3627	{
3628	dTHR;
3629	if (off >= 0) {
3630	while (off-- && s < (U8*)PL_regeol)
3631	s += UTF8SKIP(s);
3632	}
3633	else {
3634	while (off++) {
3635	if (s > (U8*)PL_bostr) {
3636	s--;
3637	if (*s & 0x80) {
3638	while (s > (U8)PL_bostr && (s & 0xc0) == 0x80)
3639	s--;
3640	} /* XXX could check well-formedness here */
3641	}
3642	}
3643	}
3644	return s;
3645	}
3646
3647	STATIC U8 *
3648	S_reghopmaybe(pTHX_ U8* s, I32 off)
3649	{
3650	dTHR;
3651	if (off >= 0) {
3652	while (off-- && s < (U8*)PL_regeol)
3653	s += UTF8SKIP(s);
3654	if (off >= 0)
3655	return 0;
3656	}
3657	else {
3658	while (off++) {
3659	if (s > (U8*)PL_bostr) {
3660	s--;
3661	if (*s & 0x80) {
3662	while (s > (U8)PL_bostr && (s & 0xc0) == 0x80)
3663	s--;
3664	} /* XXX could check well-formedness here */
3665	}
3666	else
3667	break;
3668	}
3669	if (off <= 0)
3670	return 0;
3671	}
3672	return s;
3673	}
3674
3675	#ifdef PERL_OBJECT
3676	#include "XSUB.h"
3677	#endif
3678
3679	static void
3680	restore_pos(pTHXo_ void *arg)
3681	{
3682	dTHR;
3683	if (PL_reg_eval_set) {
3684	if (PL_reg_oldsaved) {
3685	PL_reg_re->subbeg = PL_reg_oldsaved;
3686	PL_reg_re->sublen = PL_reg_oldsavedlen;
3687	RX_MATCH_COPIED_on(PL_reg_re);
3688	}
3689	PL_reg_magic->mg_len = PL_reg_oldpos;
3690	PL_reg_eval_set = 0;
3691	PL_curpm = PL_reg_oldcurpm;
3692	}
3693	}
3694

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

Download in other formats: