}
if ( count == 1 ) {
SV **tmp = av_fetch( revcharmap, idx, 0);
- char *ch = SvPV_nolen( *tmp );
+ STRLEN len;
+ char *ch = SvPV( *tmp, len );
DEBUG_OPTIMISE_r({
SV *sv=sv_newmortal();
PerlIO_printf( Perl_debug_log,
str=STRING(convert);
STR_LEN(convert)=0;
}
- while (*ch) {
+ STR_LEN(convert) += len;
+ while (len--)
*str++ = *ch++;
- STR_LEN(convert)++;
- }
-
} else {
#ifdef DEBUGGING
if (state>1)
data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
if (flags & SCF_DO_STCLASS_AND) {
for (value = 0; value < 256; value++)
- if (!is_LNBREAK_cp(value))
+ if (!is_VERTWS_cp(value))
ANYOF_BITMAP_CLEAR(data->start_class, value);
}
else {
for (value = 0; value < 256; value++)
- if (is_LNBREAK_cp(value))
+ if (is_VERTWS_cp(value))
ANYOF_BITMAP_SET(data->start_class, value);
}
if (flags & SCF_DO_STCLASS_OR)
flags &= ~SCF_DO_STCLASS;
}
min += 1;
- delta += 2;
+ delta += 1;
if (flags & SCF_DO_SUBSTR) {
SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */
data->pos_min += 1;
- data->pos_delta += 2;
+ data->pos_delta += 1;
data->longest = &(data->longest_float);
}
}
+ else if (OP(scan) == FOLDCHAR) {
+ int d = ARG(scan)==0xDF ? 1 : 2;
+ flags &= ~SCF_DO_STCLASS;
+ min += 1;
+ delta += d;
+ if (flags & SCF_DO_SUBSTR) {
+ SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */
+ data->pos_min += 1;
+ data->pos_delta += d;
+ data->longest = &(data->longest_float);
+ }
+ }
else if (strchr((const char*)PL_simple,OP(scan))) {
int value = 0;
#endif
#ifndef PERL_IN_XSUB_RE
-regexp *
-Perl_pregcomp(pTHX_ char *exp, char *xend, U32 pm_flags)
+REGEXP *
+Perl_pregcomp(pTHX_ const SV * const pattern, const U32 flags)
{
dVAR;
HV * const table = GvHV(PL_hintgv);
PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
SvIV(*ptr));
});
- return CALLREGCOMP_ENG(eng, exp, xend, pm_flags);
+ return CALLREGCOMP_ENG(eng, pattern, flags);
}
}
- return Perl_re_compile(aTHX_ exp, xend, pm_flags);
+ return Perl_re_compile(aTHX_ pattern, flags);
}
#endif
-regexp *
-Perl_re_compile(pTHX_ char *exp, char *xend, U32 pm_flags)
+REGEXP *
+Perl_re_compile(pTHX_ const SV * const pattern, const U32 pm_flags)
{
dVAR;
- register regexp *r;
+ register REGEXP *r;
register regexp_internal *ri;
+ STRLEN plen;
+ char* exp = SvPV((SV*)pattern, plen);
+ char* xend = exp + plen;
regnode *scan;
- regnode *first;
I32 flags;
I32 minlen = 0;
I32 sawplus = 0;
#endif
GET_RE_DEBUG_FLAGS_DECL;
DEBUG_r(if (!PL_colorset) reginitcolors());
-
- if (exp == NULL)
- FAIL("NULL regexp argument");
RExC_utf8 = RExC_orig_utf8 = pm_flags & RXf_UTF8;
DEBUG_COMPILE_r({
SV *dsv= sv_newmortal();
RE_PV_QUOTED_DECL(s, RExC_utf8,
- dsv, exp, (xend - exp), 60);
+ dsv, exp, plen, 60);
PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
PL_colors[4],PL_colors[5],s);
});
thing.
XXX: somehow figure out how to make this less expensive...
-- dmq */
- STRLEN len = xend-exp;
+ STRLEN len = plen;
DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
"UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
exp = (char*)Perl_bytes_to_utf8(aTHX_ (U8*)exp, &len);
RXi_SET( r, ri );
r->engine= RE_ENGINE_PTR;
r->refcnt = 1;
- r->prelen = xend - exp;
+ r->prelen = plen;
r->extflags = pm_flags;
{
bool has_k = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
struct regnode_charclass_class ch_class; /* pointed to by data */
int stclass_flag;
I32 last_close = 0; /* pointed to by data */
-
- first = scan;
+ regnode *first= scan;
+ regnode *first_next= regnext(first);
+
/* Skip introductions and multiplicators >= 1. */
while ((OP(first) == OPEN && (sawopen = 1)) ||
/* An OR of *one* alternative - should not happen now. */
- (OP(first) == BRANCH && OP(regnext(first)) != BRANCH) ||
+ (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
/* for now we can't handle lookbehind IFMATCH*/
(OP(first) == IFMATCH && !first->flags) ||
(OP(first) == PLUS) ||
(OP(first) == MINMOD) ||
/* An {n,m} with n>0 */
- (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) )
+ (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
+ (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
{
if (OP(first) == PLUS)
first += EXTRA_STEP_2ARGS;
} else /* XXX possible optimisation for /(?=)/ */
first = NEXTOPER(first);
+ first_next= regnext(first);
}
/* Starting-point info. */
SV*
-Perl_reg_named_buff_get(pTHX_ const REGEXP * const rx, SV* namesv, U32 flags)
+Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
+ const U32 flags)
+{
+ PERL_UNUSED_ARG(value);
+
+ if (flags & RXf_HASH_FETCH) {
+ return reg_named_buff_fetch(rx, key, flags);
+ } else if (flags & (RXf_HASH_STORE | RXf_HASH_DELETE | RXf_HASH_CLEAR)) {
+ Perl_croak(aTHX_ PL_no_modify);
+ return NULL;
+ } else if (flags & RXf_HASH_EXISTS) {
+ return reg_named_buff_exists(rx, key, flags)
+ ? &PL_sv_yes
+ : &PL_sv_no;
+ } else if (flags & RXf_HASH_REGNAMES) {
+ return reg_named_buff_all(rx, flags);
+ } else if (flags & (RXf_HASH_SCALAR | RXf_HASH_REGNAMES_COUNT)) {
+ return reg_named_buff_scalar(rx, flags);
+ } else {
+ Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
+ return NULL;
+ }
+}
+
+SV*
+Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
+ const U32 flags)
+{
+ PERL_UNUSED_ARG(lastkey);
+
+ if (flags & RXf_HASH_FIRSTKEY)
+ return reg_named_buff_firstkey(rx, flags);
+ else if (flags & RXf_HASH_NEXTKEY)
+ return reg_named_buff_nextkey(rx, flags);
+ else {
+ Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter", (int)flags);
+ return NULL;
+ }
+}
+
+SV*
+Perl_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const namesv, const U32 flags)
{
AV *retarray = NULL;
SV *ret;
- if (flags & 1)
+ if (flags & RXf_HASH_ALL)
retarray=newAV();
if (rx && rx->paren_names) {
SV* sv_dat=HeVAL(he_str);
I32 *nums=(I32*)SvPVX(sv_dat);
for ( i=0; i<SvIVX(sv_dat); i++ ) {
- if ((I32)(rx->nparens) >= nums[i]
- && rx->offs[nums[i]].start != -1
- && rx->offs[nums[i]].end != -1)
+ if ((I32)(rx->nparens) >= nums[i]
+ && rx->offs[nums[i]].start != -1
+ && rx->offs[nums[i]].end != -1)
{
- ret = CALLREG_NUMBUF(rx,nums[i],NULL);
+ ret = newSVpvs("");
+ CALLREG_NUMBUF_FETCH(rx,nums[i],ret);
if (!retarray)
return ret;
} else {
}
}
if (retarray)
- return (SV*)retarray;
+ return newRV((SV*)retarray);
+ }
+ }
+ return NULL;
+}
+
+bool
+Perl_reg_named_buff_exists(pTHX_ REGEXP * const rx, SV * const key,
+ const U32 flags)
+{
+ if (rx && rx->paren_names) {
+ if (flags & RXf_HASH_ALL) {
+ return hv_exists_ent(rx->paren_names, key, 0);
+ } else {
+ SV *sv = CALLREG_NAMED_BUFF_FETCH(rx, key, flags);
+ if (sv) {
+ SvREFCNT_dec(sv);
+ return TRUE;
+ } else {
+ return FALSE;
+ }
+ }
+ } else {
+ return FALSE;
+ }
+}
+
+SV*
+Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const rx, const U32 flags)
+{
+ (void)hv_iterinit(rx->paren_names);
+
+ return CALLREG_NAMED_BUFF_NEXTKEY(rx, NULL, flags & ~RXf_HASH_FIRSTKEY);
+}
+
+SV*
+Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const rx, const U32 flags)
+{
+ if (rx && rx->paren_names) {
+ HV *hv = rx->paren_names;
+ HE *temphe;
+ while ( (temphe = hv_iternext_flags(hv,0)) ) {
+ IV i;
+ IV parno = 0;
+ SV* sv_dat = HeVAL(temphe);
+ I32 *nums = (I32*)SvPVX(sv_dat);
+ for ( i = 0; i < SvIVX(sv_dat); i++ ) {
+ if ((I32)(rx->lastcloseparen) >= nums[i] &&
+ rx->offs[nums[i]].start != -1 &&
+ rx->offs[nums[i]].end != -1)
+ {
+ parno = nums[i];
+ break;
+ }
+ }
+ if (parno || flags & RXf_HASH_ALL) {
+ STRLEN len;
+ char *pv = HePV(temphe, len);
+ return newSVpvn(pv,len);
+ }
}
}
return NULL;
}
SV*
-Perl_reg_numbered_buff_get(pTHX_ const REGEXP * const rx, I32 paren, SV* usesv)
+Perl_reg_named_buff_scalar(pTHX_ REGEXP * const rx, const U32 flags)
+{
+ SV *ret;
+ AV *av;
+ I32 length;
+
+ if (rx && rx->paren_names) {
+ if (flags & (RXf_HASH_ALL | RXf_HASH_REGNAMES_COUNT)) {
+ return newSViv(HvTOTALKEYS(rx->paren_names));
+ } else if (flags & RXf_HASH_ONE) {
+ ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXf_HASH_REGNAMES));
+ av = (AV*)SvRV(ret);
+ length = av_len(av);
+ return newSViv(length + 1);
+ } else {
+ Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar", (int)flags);
+ return NULL;
+ }
+ }
+ return &PL_sv_undef;
+}
+
+SV*
+Perl_reg_named_buff_all(pTHX_ REGEXP * const rx, const U32 flags)
+{
+ AV *av = newAV();
+
+ if (rx && rx->paren_names) {
+ HV *hv= rx->paren_names;
+ HE *temphe;
+ (void)hv_iterinit(hv);
+ while ( (temphe = hv_iternext_flags(hv,0)) ) {
+ IV i;
+ IV parno = 0;
+ SV* sv_dat = HeVAL(temphe);
+ I32 *nums = (I32*)SvPVX(sv_dat);
+ for ( i = 0; i < SvIVX(sv_dat); i++ ) {
+ if ((I32)(rx->lastcloseparen) >= nums[i] &&
+ rx->offs[nums[i]].start != -1 &&
+ rx->offs[nums[i]].end != -1)
+ {
+ parno = nums[i];
+ break;
+ }
+ }
+ if (parno || flags & RXf_HASH_ALL) {
+ STRLEN len;
+ char *pv = HePV(temphe, len);
+ av_push(av, newSVpvn(pv,len));
+ }
+ }
+ }
+
+ return newRV((SV*)av);
+}
+
+void
+Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const rx, const I32 paren, SV * const sv)
{
char *s = NULL;
I32 i = 0;
I32 s1, t1;
- SV *sv = usesv ? usesv : newSVpvs("");
if (!rx->subbeg) {
sv_setsv(sv,&PL_sv_undef);
- return sv;
+ return;
}
else
- if (paren == -2 && rx->offs[0].start != -1) {
+ if (paren == RXf_PREMATCH && rx->offs[0].start != -1) {
/* $` */
i = rx->offs[0].start;
s = rx->subbeg;
}
else
- if (paren == -1 && rx->offs[0].end != -1) {
+ if (paren == RXf_POSTMATCH && rx->offs[0].end != -1) {
/* $' */
s = rx->subbeg + rx->offs[0].end;
i = rx->sublen - rx->offs[0].end;
s = rx->subbeg + s1;
} else {
sv_setsv(sv,&PL_sv_undef);
- return sv;
+ return;
}
assert(rx->sublen >= (s - rx->subbeg) + i );
if (i >= 0) {
}
} else {
sv_setsv(sv,&PL_sv_undef);
+ return;
+ }
+}
+
+void
+Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
+ SV const * const value)
+{
+ PERL_UNUSED_ARG(rx);
+ PERL_UNUSED_ARG(paren);
+ PERL_UNUSED_ARG(value);
+
+ if (!PL_localizing)
+ Perl_croak(aTHX_ PL_no_modify);
+}
+
+I32
+Perl_reg_numbered_buff_length(pTHX_ REGEXP * const rx, const SV * const sv,
+ const I32 paren)
+{
+ I32 i;
+ I32 s1, t1;
+
+ /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
+ switch (paren) {
+ /* $` / ${^PREMATCH} */
+ case RXf_PREMATCH:
+ if (rx->offs[0].start != -1) {
+ i = rx->offs[0].start;
+ if (i > 0) {
+ s1 = 0;
+ t1 = i;
+ goto getlen;
+ }
+ }
+ return 0;
+ /* $' / ${^POSTMATCH} */
+ case RXf_POSTMATCH:
+ if (rx->offs[0].end != -1) {
+ i = rx->sublen - rx->offs[0].end;
+ if (i > 0) {
+ s1 = rx->offs[0].end;
+ t1 = rx->sublen;
+ goto getlen;
+ }
+ }
+ return 0;
+ /* $& / ${^MATCH}, $1, $2, ... */
+ default:
+ if (paren <= (I32)rx->nparens &&
+ (s1 = rx->offs[paren].start) != -1 &&
+ (t1 = rx->offs[paren].end) != -1)
+ {
+ i = t1 - s1;
+ goto getlen;
+ } else {
+ if (ckWARN(WARN_UNINITIALIZED))
+ report_uninit((SV*)sv);
+ return 0;
+ }
}
- return sv;
+ getlen:
+ if (i > 0 && RX_MATCH_UTF8(rx)) {
+ const char * const s = rx->subbeg + s1;
+ const U8 *ep;
+ STRLEN el;
+
+ i = t1 - s1;
+ if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
+ i = el;
+ }
+ return i;
}
SV*
-Perl_reg_qr_pkg(pTHX_ const REGEXP * const rx)
+Perl_reg_qr_package(pTHX_ REGEXP * const rx)
{
PERL_UNUSED_ARG(rx);
return newSVpvs("Regexp");
{
STRLEN numlen = 1;
SV * const sv = sv_2mortal(newSVpvn(&value, numlen));
- const char * const s = encp && *encp ? sv_recode_to_utf8(sv, *encp)
- : SvPVX(sv);
+ const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv);
const STRLEN newlen = SvCUR(sv);
UV uv = UNICODE_REPLACEMENT;
if (!newlen || numlen != newlen) {
uv = UNICODE_REPLACEMENT;
- if (encp)
- *encp = NULL;
+ *encp = NULL;
}
return uv;
}
tryagain:
- switch (*RExC_parse) {
+ switch ((U8)*RExC_parse) {
case '^':
RExC_seen_zerolen++;
nextchar(pRExC_state);
RExC_parse++;
vFAIL("Quantifier follows nothing");
break;
+ case 0xDF:
+ case 0xC3:
+ case 0xCE:
+ if (!LOC && FOLD) {
+ U32 len,cp;
+ if ((cp = what_len_TRICKYFOLD_safe(RExC_parse,RExC_end,UTF,len))) {
+ *flagp |= HASWIDTH; /* could be SIMPLE too, but needs a handler in regexec.regrepeat */
+ RExC_parse+=len-1; /* we get one from nextchar() as well. :-( */
+ ret = reganode(pRExC_state, FOLDCHAR, cp);
+ Set_Node_Length(ret, 1); /* MJD */
+ nextchar(pRExC_state); /* kill whitespace under /x */
+ return ret;
+ }
+ }
+ goto outer_default;
case '\\':
/* Special Escapes
}
/* FALL THROUGH */
- default: {
+ default:
+ outer_default:{
register STRLEN len;
register UV ender;
register char *p;
if (RExC_flags & RXf_PMf_EXTENDED)
p = regwhite( pRExC_state, p );
- switch (*p) {
+ switch ((U8)*p) {
+ case 0xDF:
+ case 0xC3:
+ case 0xCE:
+ if (LOC || !FOLD || !is_TRICKYFOLD_safe(p,RExC_end,UTF))
+ goto normal_default;
case '^':
case '$':
case '.':
SVfARG((SV*)progi->data->data[ ARG( o ) ]));
} else if (k == LOGICAL)
Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* 2: embedded, otherwise 1 */
+ else if (k == FOLDCHAR)
+ Perl_sv_catpvf(aTHX_ sv, "[0x%"UVXf"]",ARG(o) );
else if (k == ANYOF) {
int i, rangestart = -1;
const U8 flags = ANYOF_FLAGS(o);
}
SV *
-Perl_re_intuit_string(pTHX_ regexp *prog)
+Perl_re_intuit_string(pTHX_ REGEXP * const prog)
{ /* Assume that RE_INTUIT is set */
dVAR;
GET_RE_DEBUG_FLAGS_DECL;
}
RX_MATCH_COPIED_off(ret);
#ifdef PERL_OLD_COPY_ON_WRITE
- /* this is broken. */
- assert(0);
- if (ret->saved_copy)
- ret->saved_copy=NULL;
+ ret->saved_copy = NULL;
#endif
ret->mother_re = r;
ret->swap = NULL;
*/
void
-Perl_regfree_internal(pTHX_ struct regexp *r)
+Perl_regfree_internal(pTHX_ REGEXP * const r)
{
dVAR;
RXi_GET_DECL(r,ri);
*/
void *
-Perl_regdupe_internal(pTHX_ const regexp *r, CLONE_PARAMS *param)
+Perl_regdupe_internal(pTHX_ REGEXP * const r, CLONE_PARAMS *param)
{
dVAR;
regexp_internal *reti;
projects / p5sagit/p5-mst-13.2.git / blobdiff