deleted from the finite automaton. */
char *
-Perl_re_intuit_start(pTHX_ REGEXP * const prog, SV *sv, char *strpos,
+Perl_re_intuit_start(pTHX_ REGEXP * const rx, SV *sv, char *strpos,
char *strend, const U32 flags, re_scream_pos_data *data)
{
dVAR;
+ struct regexp *const prog = (struct regexp *)SvANY(rx);
register I32 start_shift = 0;
/* Should be nonnegative! */
register I32 end_shift = 0;
GET_RE_DEBUG_FLAGS_DECL;
- RX_MATCH_UTF8_set(prog,do_utf8);
+ RX_MATCH_UTF8_set(rx,do_utf8);
- if (prog->extflags & RXf_UTF8) {
+ if (RX_UTF8(rx)) {
PL_reg_flags |= RF_utf8;
}
DEBUG_EXECUTE_r(
- debug_start_match(prog, do_utf8, strpos, strend,
+ debug_start_match(rx, do_utf8, strpos, strend,
sv ? "Guessing start of match in sv for"
: "Guessing start of match in string for");
);
#ifdef QDEBUGGING /* 7/99: reports of failure (with the older version) */
if (end_shift < 0)
Perl_croak(aTHX_ "panic: end_shift: %"IVdf" pattern:\n%s\n ",
- (IV)end_shift, prog->precomp);
+ (IV)end_shift, RX_PRECOMP(prog));
#endif
restart:
else
goto fail_finish;
/* we may be pointing at the wrong string */
- if (s && RX_MATCH_COPIED(prog))
+ if (s && RXp_MATCH_COPIED(prog))
s = strbeg + (s - SvPVX_const(sv));
if (data)
*data->scream_olds = s;
return NULL;
}
-
+#define DECL_TRIE_TYPE(scan) \
+ const enum { trie_plain, trie_utf8, trie_utf8_fold, trie_latin_utf8_fold } \
+ trie_type = (scan->flags != EXACT) \
+ ? (do_utf8 ? trie_utf8_fold : (UTF ? trie_latin_utf8_fold : trie_plain)) \
+ : (do_utf8 ? trie_utf8 : trie_plain)
#define REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc, uscan, len, \
uvc, charid, foldlen, foldbuf, uniflags) STMT_START { \
uscan = foldbuf + UNISKIP( uvc ); \
} \
break; \
+ case trie_latin_utf8_fold: \
+ if ( foldlen>0 ) { \
+ uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags ); \
+ foldlen -= len; \
+ uscan += len; \
+ len=0; \
+ } else { \
+ len = 1; \
+ uvc = to_uni_fold( *(U8*)uc, foldbuf, &foldlen ); \
+ foldlen -= UNISKIP( uvc ); \
+ uscan = foldbuf + UNISKIP( uvc ); \
+ } \
+ break; \
case trie_utf8: \
uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags ); \
break; \
} \
} STMT_END
-#define REXEC_FBC_EXACTISH_CHECK(CoNd) \
+#define REXEC_FBC_EXACTISH_CHECK(CoNd) \
+{ \
+ char *my_strend= (char *)strend; \
if ( (CoNd) \
&& (ln == len || \
- ibcmp_utf8(s, NULL, 0, do_utf8, \
+ !ibcmp_utf8(s, &my_strend, 0, do_utf8, \
m, NULL, ln, (bool)UTF)) \
- && (!reginfo || regtry(reginfo, &s)) ) \
+ && (!reginfo || regtry(reginfo, &s)) ) \
goto got_it; \
else { \
U8 foldbuf[UTF8_MAXBYTES_CASE+1]; \
f = to_utf8_fold(tmpbuf, foldbuf, &foldlen); \
if ( f != c \
&& (f == c1 || f == c2) \
- && (ln == foldlen || \
- !ibcmp_utf8((char *) foldbuf, \
- NULL, foldlen, do_utf8, \
- m, \
- NULL, ln, (bool)UTF)) \
- && (!reginfo || regtry(reginfo, &s)) ) \
+ && (ln == len || \
+ !ibcmp_utf8(s, &my_strend, 0, do_utf8,\
+ m, NULL, ln, (bool)UTF)) \
+ && (!reginfo || regtry(reginfo, &s)) ) \
goto got_it; \
} \
- s += len
+} \
+s += len
#define REXEC_FBC_EXACTISH_SCAN(CoNd) \
STMT_START { \
U8 *sm = (U8 *) m;
U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
- const U32 uniflags = UTF8_ALLOW_DEFAULT;
-
- to_utf8_lower((U8*)m, tmpbuf1, &ulen1);
- to_utf8_upper((U8*)m, tmpbuf2, &ulen2);
-
+ /* used by commented-out code below */
+ /*const U32 uniflags = UTF8_ALLOW_DEFAULT;*/
+
+ /* XXX: Since the node will be case folded at compile
+ time this logic is a little odd, although im not
+ sure that its actually wrong. --dmq */
+
+ c1 = to_utf8_lower((U8*)m, tmpbuf1, &ulen1);
+ c2 = to_utf8_upper((U8*)m, tmpbuf2, &ulen2);
+
+ /* XXX: This is kinda strange. to_utf8_XYZ returns the
+ codepoint of the first character in the converted
+ form, yet originally we did the extra step.
+ No tests fail by commenting this code out however
+ so Ive left it out. -- dmq.
+
c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXBYTES_CASE,
0, uniflags);
c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXBYTES_CASE,
0, uniflags);
+ */
+
lnc = 0;
while (sm < ((U8 *) m + ln)) {
lnc++;
* matching (called "loose matching" in Unicode).
* ibcmp_utf8() will do just that. */
- if (do_utf8) {
+ if (do_utf8 || UTF) {
UV c, f;
U8 tmpbuf [UTF8_MAXBYTES+1];
- STRLEN len, foldlen;
+ STRLEN len = 1;
+ STRLEN foldlen;
const U32 uniflags = UTF8_ALLOW_DEFAULT;
if (c1 == c2) {
/* Upper and lower of 1st char are equal -
* probably not a "letter". */
while (s <= e) {
- c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
+ if (do_utf8) {
+ c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
uniflags);
+ } else {
+ c = *((U8*)s);
+ }
REXEC_FBC_EXACTISH_CHECK(c == c1);
}
}
else {
while (s <= e) {
- c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
+ if (do_utf8) {
+ c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
uniflags);
+ } else {
+ c = *((U8*)s);
+ }
/* Handle some of the three Greek sigmas cases.
* Note that not all the possible combinations
}
}
else {
+ /* Neither pattern nor string are UTF8 */
if (c1 == c2)
REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1);
else
case AHOCORASICKC:
case AHOCORASICK:
{
- const enum { trie_plain, trie_utf8, trie_utf8_fold }
- trie_type = do_utf8 ?
- (c->flags == EXACT ? trie_utf8 : trie_utf8_fold)
- : trie_plain;
+ DECL_TRIE_TYPE(c);
/* what trie are we using right now */
reg_ac_data *aho
= (reg_ac_data*)progi->data->data[ ARG( c ) ];
- regexec_flags - match a regexp against a string
*/
I32
-Perl_regexec_flags(pTHX_ REGEXP * const prog, char *stringarg, register char *strend,
+Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, register char *strend,
char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
/* strend: pointer to null at end of string */
/* strbeg: real beginning of string */
/* nosave: For optimizations. */
{
dVAR;
+ struct regexp *const prog = (struct regexp *)SvANY(rx);
/*register*/ char *s;
register regnode *c;
/*register*/ char *startpos = stringarg;
}
multiline = prog->extflags & RXf_PMf_MULTILINE;
- reginfo.prog = prog;
+ reginfo.prog = rx; /* Yes, sorry that this is confusing. */
- RX_MATCH_UTF8_set(prog, do_utf8);
+ RX_MATCH_UTF8_set(rx, do_utf8);
DEBUG_EXECUTE_r(
- debug_start_match(prog, do_utf8, startpos, strend,
+ debug_start_match(rx, do_utf8, startpos, strend,
"Matching");
);
PL_reg_eval_set = 0;
PL_reg_maxiter = 0;
- if (prog->extflags & RXf_UTF8)
+ if (RX_UTF8(rx))
PL_reg_flags |= RF_utf8;
/* Mark beginning of line for ^ and lookbehind. */
} else /* pos() not defined */
reginfo.ganch = strbeg;
}
- if (PL_curpm && (PM_GETRE(PL_curpm) == prog)) {
+ if (PL_curpm && (PM_GETRE(PL_curpm) == rx)) {
swap_on_fail = 1;
swap_match_buff(prog); /* do we need a save destructor here for
eval dies? */
d.scream_olds = &scream_olds;
d.scream_pos = &scream_pos;
- s = re_intuit_start(prog, sv, s, strend, flags, &d);
+ s = re_intuit_start(rx, sv, s, strend, flags, &d);
if (!s) {
DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
goto phooey; /* not present */
if (s > end)
goto phooey;
if (prog->extflags & RXf_USE_INTUIT) {
- s = re_intuit_start(prog, sv, s + 1, strend, flags, NULL);
+ s = re_intuit_start(rx, sv, s + 1, strend, flags, NULL);
if (!s)
goto phooey;
}
(unsigned char*)strend, must,
multiline ? FBMrf_MULTILINE : 0))) ) {
/* we may be pointing at the wrong string */
- if ((flags & REXEC_SCREAM) && RX_MATCH_COPIED(prog))
+ if ((flags & REXEC_SCREAM) && RXp_MATCH_COPIED(prog))
s = strbeg + (s - SvPVX_const(sv));
DEBUG_EXECUTE_r( did_match = 1 );
if (HOPc(s, -back_max) > last1) {
if (!last)
last = scream_olds; /* Only one occurrence. */
/* we may be pointing at the wrong string */
- else if (RX_MATCH_COPIED(prog))
+ else if (RXp_MATCH_COPIED(prog))
s = strbeg + (s - SvPVX_const(sv));
}
else {
goto phooey;
got_it:
- RX_MATCH_TAINTED_set(prog, PL_reg_flags & RF_tainted);
+ RX_MATCH_TAINTED_set(rx, PL_reg_flags & RF_tainted);
if (PL_reg_eval_set)
restore_pos(aTHX_ prog);
- if (prog->paren_names)
- (void)hv_iterinit(prog->paren_names);
+ if (RXp_PAREN_NAMES(prog))
+ (void)hv_iterinit(RXp_PAREN_NAMES(prog));
/* make sure $`, $&, $', and $digit will work later */
if ( !(flags & REXEC_NOT_FIRST) ) {
- RX_MATCH_COPY_FREE(prog);
+ RX_MATCH_COPY_FREE(rx);
if (flags & REXEC_COPY_STR) {
const I32 i = PL_regeol - startpos + (stringarg - strbeg);
#ifdef PERL_OLD_COPY_ON_WRITE
} else
#endif
{
- RX_MATCH_COPIED_on(prog);
+ RX_MATCH_COPIED_on(rx);
s = savepvn(strbeg, i);
prog->subbeg = s;
}
{
dVAR;
CHECKPOINT lastcp;
- regexp *prog = reginfo->prog;
+ REGEXP *const rx = reginfo->prog;
+ regexp *const prog = (struct regexp *)SvANY(rx);
RXi_GET_DECL(prog,progi);
GET_RE_DEBUG_FLAGS_DECL;
reginfo->cutpoint=NULL;
#ifdef USE_ITHREADS
{
SV* const repointer = newSViv(0);
- /* so we know which PL_regex_padav element is PL_reg_curpm */
+ /* so we know which PL_regex_padav element is PL_reg_curpm
+ when clearing up in perl_destruct() */
SvFLAGS(repointer) |= SVf_BREAK;
- av_push(PL_regex_padav,repointer);
+ av_push(PL_regex_padav, repointer);
PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
PL_regex_pad = AvARRAY(PL_regex_padav);
}
#endif
}
- PM_SETRE(PL_reg_curpm, prog);
+ PM_SETRE(PL_reg_curpm, rx);
PL_reg_oldcurpm = PL_curpm;
PL_curpm = PL_reg_curpm;
- if (RX_MATCH_COPIED(prog)) {
+ if (RXp_MATCH_COPIED(prog)) {
/* Here is a serious problem: we cannot rewrite subbeg,
since it may be needed if this match fails. Thus
$` inside (?{}) could fail... */
#ifdef PERL_OLD_COPY_ON_WRITE
PL_nrs = prog->saved_copy;
#endif
- RX_MATCH_COPIED_off(prog);
+ RXp_MATCH_COPIED_off(prog);
}
else
PL_reg_oldsaved = NULL;
#ifdef DEBUGGING
STATIC void
-S_debug_start_match(pTHX_ const regexp *prog, const bool do_utf8,
+S_debug_start_match(pTHX_ const REGEXP *prog, const bool do_utf8,
const char *start, const char *end, const char *blurb)
{
- const bool utf8_pat= prog->extflags & RXf_UTF8 ? 1 : 0;
+ const bool utf8_pat = RX_UTF8(prog) ? 1 : 0;
if (!PL_colorset)
reginitcolors();
{
RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0),
- prog->precomp, prog->prelen, 60);
+ RX_PRECOMP(prog), RX_PRELEN(prog), 60);
RE_PV_QUOTED_DECL(s1, do_utf8, PERL_DEBUG_PAD_ZERO(1),
start, end - start, 60);
register const bool do_utf8 = PL_reg_match_utf8;
const U32 uniflags = UTF8_ALLOW_DEFAULT;
- regexp *rex = reginfo->prog;
+ REGEXP *rex_sv = reginfo->prog;
+ regexp *rex = (struct regexp *)SvANY(rex_sv);
RXi_GET_DECL(rex,rexi);
I32 oldsave;
case TRIE:
{
/* what type of TRIE am I? (utf8 makes this contextual) */
- const enum { trie_plain, trie_utf8, trie_utf8_fold }
- trie_type = do_utf8 ?
- (scan->flags == EXACT ? trie_utf8 : trie_utf8_fold)
- : trie_plain;
+ DECL_TRIE_TYPE(scan);
/* what trie are we using right now */
reg_trie_data * const trie
#define ST st->u.eval
{
SV *ret;
+ REGEXP *re_sv;
regexp *re;
regexp_internal *rei;
regnode *startpoint;
} else {
nochange_depth = 0;
}
+ re_sv = rex_sv;
re = rex;
rei = rexi;
- (void)ReREFCNT_inc(rex);
+ (void)ReREFCNT_inc(rex_sv);
if (OP(scan)==GOSUB) {
startpoint = scan + ARG2L(scan);
ST.close_paren = ARG(scan);
{
/* extract RE object from returned value; compiling if
* necessary */
-
MAGIC *mg = NULL;
- const SV *sv;
- if(SvROK(ret) && SvSMAGICAL(sv = SvRV(ret)))
- mg = mg_find(sv, PERL_MAGIC_qr);
- else if (SvSMAGICAL(ret)) {
- if (SvGMAGICAL(ret))
+ REGEXP *rx = NULL;
+
+ if (SvROK(ret)) {
+ SV *const sv = SvRV(ret);
+
+ if (SvTYPE(sv) == SVt_REGEXP) {
+ rx = (REGEXP*) sv;
+ } else if (SvSMAGICAL(sv)) {
+ mg = mg_find(sv, PERL_MAGIC_qr);
+ assert(mg);
+ }
+ } else if (SvTYPE(ret) == SVt_REGEXP) {
+ rx = (REGEXP*) ret;
+ } else if (SvSMAGICAL(ret)) {
+ if (SvGMAGICAL(ret)) {
+ /* I don't believe that there is ever qr magic
+ here. */
+ assert(!mg_find(ret, PERL_MAGIC_qr));
sv_unmagic(ret, PERL_MAGIC_qr);
- else
+ }
+ else {
mg = mg_find(ret, PERL_MAGIC_qr);
+ /* testing suggests mg only ends up non-NULL for
+ scalars who were upgraded and compiled in the
+ else block below. In turn, this is only
+ triggered in the "postponed utf8 string" tests
+ in t/op/pat.t */
+ }
}
if (mg) {
- re = reg_temp_copy((regexp *)mg->mg_obj); /*XXX:dmq*/
+ rx = (REGEXP *) mg->mg_obj; /*XXX:dmq*/
+ assert(rx);
+ }
+ if (rx) {
+ rx = reg_temp_copy(rx);
}
else {
U32 pm_flags = 0;
const I32 osize = PL_regsize;
- if (DO_UTF8(ret)) pm_flags |= RXf_UTF8;
- re = CALLREGCOMP(ret, pm_flags);
+ if (DO_UTF8(ret)) {
+ assert (SvUTF8(ret));
+ } else if (SvUTF8(ret)) {
+ /* Not doing UTF-8, despite what the SV says. Is
+ this only if we're trapped in use 'bytes'? */
+ /* Make a copy of the octet sequence, but without
+ the flag on, as the compiler now honours the
+ SvUTF8 flag on ret. */
+ STRLEN len;
+ const char *const p = SvPV(ret, len);
+ ret = newSVpvn_flags(p, len, SVs_TEMP);
+ }
+ rx = CALLREGCOMP(ret, pm_flags);
if (!(SvFLAGS(ret)
& (SVs_TEMP | SVs_PADTMP | SVf_READONLY
- | SVs_GMG)))
- sv_magic(ret,(SV*)ReREFCNT_inc(re),
- PERL_MAGIC_qr,0,0);
+ | SVs_GMG))) {
+ /* This isn't a first class regexp. Instead, it's
+ caching a regexp onto an existing, Perl visible
+ scalar. */
+ sv_magic(ret, (SV*) rx, PERL_MAGIC_qr, 0, 0);
+ }
PL_regsize = osize;
}
+ re_sv = rx;
+ re = (struct regexp *)SvANY(rx);
}
- RX_MATCH_COPIED_off(re);
+ RXp_MATCH_COPIED_off(re);
re->subbeg = rex->subbeg;
re->sublen = rex->sublen;
rei = RXi_GET(re);
DEBUG_EXECUTE_r(
- debug_start_match(re, do_utf8, locinput, PL_regeol,
+ debug_start_match(re_sv, do_utf8, locinput, PL_regeol,
"Matching embedded");
);
startpoint = rei->program + 1;
PL_regoffs = re->offs; /* essentially NOOP on GOSUB */
- *PL_reglastparen = 0;
- *PL_reglastcloseparen = 0;
+ /* see regtry, specifically PL_reglast(?:close)?paren is a pointer! (i dont know why) :dmq */
+ PL_reglastparen = &re->lastparen;
+ PL_reglastcloseparen = &re->lastcloseparen;
+ re->lastparen = 0;
+ re->lastcloseparen = 0;
+
PL_reginput = locinput;
PL_regsize = 0;
PL_reg_maxiter = 0;
ST.toggle_reg_flags = PL_reg_flags;
- if (re->extflags & RXf_UTF8)
+ if (RX_UTF8(re_sv))
PL_reg_flags |= RF_utf8;
else
PL_reg_flags &= ~RF_utf8;
ST.toggle_reg_flags ^= PL_reg_flags; /* diff of old and new */
- ST.prev_rex = rex;
+ ST.prev_rex = rex_sv;
ST.prev_curlyx = cur_curlyx;
- SETREX(rex,re);
+ SETREX(rex_sv,re_sv);
+ rex = re;
rexi = rei;
cur_curlyx = NULL;
ST.B = next;
case EVAL_AB: /* cleanup after a successful (??{A})B */
/* note: this is called twice; first after popping B, then A */
PL_reg_flags ^= ST.toggle_reg_flags;
- ReREFCNT_dec(rex);
- SETREX(rex,ST.prev_rex);
+ ReREFCNT_dec(rex_sv);
+ SETREX(rex_sv,ST.prev_rex);
+ rex = (struct regexp *)SvANY(rex_sv);
rexi = RXi_GET(rex);
regcpblow(ST.cp);
cur_eval = ST.prev_eval;
cur_curlyx = ST.prev_curlyx;
+
+ PL_reglastparen = &rex->lastparen;
+ PL_reglastcloseparen = &rex->lastcloseparen;
+
/* XXXX This is too dramatic a measure... */
PL_reg_maxiter = 0;
if ( nochange_depth )
case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
/* note: this is called twice; first after popping B, then A */
PL_reg_flags ^= ST.toggle_reg_flags;
- ReREFCNT_dec(rex);
- SETREX(rex,ST.prev_rex);
+ ReREFCNT_dec(rex_sv);
+ SETREX(rex_sv,ST.prev_rex);
+ rex = (struct regexp *)SvANY(rex_sv);
rexi = RXi_GET(rex);
+ PL_reglastparen = &rex->lastparen;
+ PL_reglastcloseparen = &rex->lastcloseparen;
+
PL_reginput = locinput;
REGCP_UNWIND(ST.lastcp);
regcppop(rex);
= cur_eval->u.eval.toggle_reg_flags;
PL_reg_flags ^= st->u.eval.toggle_reg_flags;
- st->u.eval.prev_rex = rex; /* inner */
- SETREX(rex,cur_eval->u.eval.prev_rex);
+ st->u.eval.prev_rex = rex_sv; /* inner */
+ SETREX(rex_sv,cur_eval->u.eval.prev_rex);
+ rex = (struct regexp *)SvANY(rex_sv);
rexi = RXi_GET(rex);
cur_curlyx = cur_eval->u.eval.prev_curlyx;
- ReREFCNT_inc(rex);
+ ReREFCNT_inc(rex_sv);
st->u.eval.cp = regcppush(0); /* Save *all* the positions. */
REGCP_SET(st->u.eval.lastcp);
PL_reginput = locinput;
} else {
while (scan < loceol && !isSPACE(*scan))
scan++;
- break;
}
+ break;
case NSPACEL:
PL_reg_flags |= RF_tainted;
if (do_utf8) {
#ifdef PERL_OLD_COPY_ON_WRITE
rex->saved_copy = PL_nrs;
#endif
- RX_MATCH_COPIED_on(rex);
+ RXp_MATCH_COPIED_on(rex);
}
PL_reg_magic->mg_len = PL_reg_oldpos;
PL_reg_eval_set = 0;
projects / p5sagit/p5-mst-13.2.git / blobdiff