Context Navigation

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

Visit:

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

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

Download in other formats: