From: Yves Orton Date: Tue, 13 Feb 2007 20:27:33 +0000 (+0100) Subject: add hooks for capture buffers into regex engine. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=93b32b6daeecaf211c8a9bf2a93d0f4701c279ab;p=p5sagit%2Fp5-mst-13.2.git add hooks for capture buffers into regex engine. Message-ID: <9b18b3110702131127q79cc6df1lb1480d9a40d15213@mail.gmail.com> p4raw-id: //depot/perl@30265 --- diff --git a/embed.fnc b/embed.fnc index d5d0625..b41e2ea 100644 --- a/embed.fnc +++ b/embed.fnc @@ -691,8 +691,10 @@ Ap |I32 |regexec_flags |NN regexp* prog|NN char* stringarg \ |NN char* strend|NN char* strbeg|I32 minend \ |NN SV* screamer|NULLOK void* data|U32 flags ApR |regnode*|regnext |NN regnode* p -EXp |SV*|reg_named_buff_get |NN SV* namesv|NULLOK const REGEXP * const from_re|U32 flags -EXp |SV*|reg_numbered_buff_get|I32 paren|NN const REGEXP * const rx|NULLOK SV* usesv|U32 flags + +EXp |SV*|reg_named_buff_get |NN const REGEXP * const rx|NN SV* namesv|U32 flags +EXp |SV*|reg_numbered_buff_get|NN const REGEXP * const rx|I32 paren|NULLOK SV* usesv + Ep |void |regprop |NULLOK const regexp *prog|NN SV* sv|NN const regnode* o Ap |void |repeatcpy |NN char* to|NN const char* from|I32 len|I32 count ApP |char* |rninstr |NN const char* big|NN const char* bigend \ diff --git a/embed.h b/embed.h index 112ba79..f2c2a9d 100644 --- a/embed.h +++ b/embed.h @@ -698,6 +698,8 @@ #if defined(PERL_CORE) || defined(PERL_EXT) #define reg_named_buff_get Perl_reg_named_buff_get #define reg_numbered_buff_get Perl_reg_numbered_buff_get +#endif +#if defined(PERL_CORE) || defined(PERL_EXT) #define regprop Perl_regprop #endif #define repeatcpy Perl_repeatcpy @@ -2915,7 +2917,9 @@ #define regnext(a) Perl_regnext(aTHX_ a) #if defined(PERL_CORE) || defined(PERL_EXT) #define reg_named_buff_get(a,b,c) Perl_reg_named_buff_get(aTHX_ a,b,c) -#define reg_numbered_buff_get(a,b,c,d) Perl_reg_numbered_buff_get(aTHX_ a,b,c,d) +#define reg_numbered_buff_get(a,b,c) Perl_reg_numbered_buff_get(aTHX_ a,b,c) +#endif +#if defined(PERL_CORE) || defined(PERL_EXT) #define regprop(a,b,c) Perl_regprop(aTHX_ a,b,c) #endif #define repeatcpy(a,b,c,d) Perl_repeatcpy(aTHX_ a,b,c,d) diff --git a/ext/re/re.xs b/ext/re/re.xs index 1bc20fc..185fc74 100644 --- a/ext/re/re.xs +++ b/ext/re/re.xs @@ -22,6 +22,8 @@ extern char* my_re_intuit_start (pTHX_ regexp *prog, SV *sv, char *strpos, extern SV* my_re_intuit_string (pTHX_ regexp *prog); extern void my_regfree (pTHX_ struct regexp* r); +extern SV* my_reg_numbered_buff_get(pTHX_ const REGEXP * const rx, I32 paren, SV* usesv); +extern SV* my_reg_named_buff_get(pTHX_ const REGEXP * const rx, SV* namesv, U32 flags); #if defined(USE_ITHREADS) extern void* my_regdupe (pTHX_ const regexp *r, CLONE_PARAMS *param); #endif @@ -36,6 +38,8 @@ const struct regexp_engine my_reg_engine = { my_re_intuit_start, my_re_intuit_string, my_regfree, + my_reg_numbered_buff_get, + my_reg_named_buff_get, #if defined(USE_ITHREADS) my_regdupe #endif @@ -213,7 +217,7 @@ PPCODE: { re = get_re_arg( aTHX_ qr, 1, NULL); if (SvPOK(sv) && re && re->paren_names) { - bufs = Perl_reg_named_buff_get(aTHX_ sv, re ,all && SvTRUE(all)); + bufs = CALLREG_NAMEDBUF(re,sv,all && SvTRUE(all)); if (bufs) { if (all && SvTRUE(all)) XPUSHs(newRV(bufs)); diff --git a/ext/re/re_top.h b/ext/re/re_top.h index b4a3d6f..7f53a74 100644 --- a/ext/re/re_top.h +++ b/ext/re/re_top.h @@ -16,6 +16,8 @@ #define Perl_regfree_internal my_regfree #define Perl_re_intuit_string my_re_intuit_string #define Perl_regdupe_internal my_regdupe +#define Perl_reg_numbered_buff_get my_reg_numbered_buff_get +#define Perl_reg_named_buff_get my_reg_named_buff_get #define PERL_NO_GET_CONTEXT diff --git a/mg.c b/mg.c index ecd8ad5..8dfbac3 100644 --- a/mg.c +++ b/mg.c @@ -863,7 +863,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) * XXX Does the new way break anything? */ paren = atoi(mg->mg_ptr); /* $& is in [0] */ - reg_numbered_buff_get( paren, rx, sv, 0); + CALLREG_NUMBUF(rx,paren,sv); break; } sv_setsv(sv,&PL_sv_undef); @@ -872,7 +872,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '+': if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { if (rx->lastparen) { - reg_numbered_buff_get( rx->lastparen, rx, sv, 0); + CALLREG_NUMBUF(rx,rx->lastparen,sv); break; } } @@ -881,7 +881,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '\016': /* ^N */ if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { if (rx->lastcloseparen) { - reg_numbered_buff_get( rx->lastcloseparen, rx, sv, 0); + CALLREG_NUMBUF(rx,rx->lastcloseparen,sv); break; } @@ -891,16 +891,16 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '`': do_prematch_fetch: if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - reg_numbered_buff_get( -2, rx, sv, 0); - break; + CALLREG_NUMBUF(rx,-2,sv); + break; } sv_setsv(sv,&PL_sv_undef); break; case '\'': do_postmatch_fetch: if (PL_curpm && (rx = PM_GETRE(PL_curpm))) { - reg_numbered_buff_get( -1, rx, sv, 0); - break; + CALLREG_NUMBUF(rx,-1,sv); + break; } sv_setsv(sv,&PL_sv_undef); break; diff --git a/perl.h b/perl.h index f1c88d4..6104c63 100644 --- a/perl.h +++ b/perl.h @@ -219,6 +219,13 @@ #define CALLREGFREE_PVT(prog) \ if(prog) CALL_FPTR((prog)->engine->free)(aTHX_ (prog)) +#define CALLREG_NUMBUF(rx,paren,usesv) \ + CALL_FPTR((rx)->engine->numbered_buff_get)(aTHX_ (rx),(paren),(usesv)) + +#define CALLREG_NAMEDBUF(rx,name,flags) \ + CALL_FPTR((rx)->engine->named_buff_get)(aTHX_ (rx),(name),(flags)) + + #if defined(USE_ITHREADS) #define CALLREGDUPE(prog,param) \ Perl_re_dup(aTHX_ (prog),(param)) diff --git a/proto.h b/proto.h index a9d6c93..ae03e11 100644 --- a/proto.h +++ b/proto.h @@ -1888,12 +1888,15 @@ PERL_CALLCONV regnode* Perl_regnext(pTHX_ regnode* p) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); -PERL_CALLCONV SV* Perl_reg_named_buff_get(pTHX_ SV* namesv, const REGEXP * const from_re, U32 flags) - __attribute__nonnull__(pTHX_1); -PERL_CALLCONV SV* Perl_reg_numbered_buff_get(pTHX_ I32 paren, const REGEXP * const rx, SV* usesv, U32 flags) +PERL_CALLCONV SV* Perl_reg_named_buff_get(pTHX_ const REGEXP * const rx, SV* namesv, U32 flags) + __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); +PERL_CALLCONV SV* Perl_reg_numbered_buff_get(pTHX_ const REGEXP * const rx, I32 paren, SV* usesv) + __attribute__nonnull__(pTHX_1); + + PERL_CALLCONV void Perl_regprop(pTHX_ const regexp *prog, SV* sv, const regnode* o) __attribute__nonnull__(pTHX_2) __attribute__nonnull__(pTHX_3); diff --git a/regcomp.c b/regcomp.c index 8b108f5..e0a0f5c 100644 --- a/regcomp.c +++ b/regcomp.c @@ -4692,58 +4692,53 @@ reStudy: return(r); } -#undef CORE_ONLY_BLOCK #undef RE_ENGINE_PTR -#ifndef PERL_IN_XSUB_RE + SV* -Perl_reg_named_buff_get(pTHX_ SV* namesv, const REGEXP * const from_re, U32 flags) +Perl_reg_named_buff_get(pTHX_ const REGEXP * const rx, SV* namesv, U32 flags) { AV *retarray = NULL; SV *ret; if (flags & 1) retarray=newAV(); - - if (from_re || PL_curpm) { - const REGEXP * const rx = from_re ? from_re : PM_GETRE(PL_curpm); - if (rx && rx->paren_names) { - HE *he_str = hv_fetch_ent( rx->paren_names, namesv, 0, 0 ); - if (he_str) { - IV i; - SV* sv_dat=HeVAL(he_str); - I32 *nums=(I32*)SvPVX(sv_dat); - for ( i=0; inparens) >= nums[i] - && rx->startp[nums[i]] != -1 - && rx->endp[nums[i]] != -1) - { - ret = reg_numbered_buff_get(nums[i],rx,NULL,0); - if (!retarray) - return ret; - } else { - ret = newSVsv(&PL_sv_undef); - } - if (retarray) { - SvREFCNT_inc(ret); - av_push(retarray, ret); - } + + if (rx && rx->paren_names) { + HE *he_str = hv_fetch_ent( rx->paren_names, namesv, 0, 0 ); + if (he_str) { + IV i; + SV* sv_dat=HeVAL(he_str); + I32 *nums=(I32*)SvPVX(sv_dat); + for ( i=0; inparens) >= nums[i] + && rx->startp[nums[i]] != -1 + && rx->endp[nums[i]] != -1) + { + ret = CALLREG_NUMBUF(rx,nums[i],NULL); + if (!retarray) + return ret; + } else { + ret = newSVsv(&PL_sv_undef); + } + if (retarray) { + SvREFCNT_inc(ret); + av_push(retarray, ret); } - if (retarray) - return (SV*)retarray; } + if (retarray) + return (SV*)retarray; } } return NULL; } SV* -Perl_reg_numbered_buff_get(pTHX_ I32 paren, const REGEXP * const rx, SV* usesv, U32 flags) +Perl_reg_numbered_buff_get(pTHX_ const REGEXP * const rx, I32 paren, SV* usesv) { char *s = NULL; I32 i = 0; I32 s1, t1; SV *sv = usesv ? usesv : newSVpvs(""); - PERL_UNUSED_ARG(flags); if (!rx->subbeg) { sv_setsv(sv,&PL_sv_undef); @@ -4812,7 +4807,7 @@ Perl_reg_numbered_buff_get(pTHX_ I32 paren, const REGEXP * const rx, SV* usesv, } return sv; } -#endif + /* Scans the name of a named buffer from the pattern. * If flags is REG_RSN_RETURN_NULL returns null. diff --git a/regcomp.h b/regcomp.h index 3d08ac8..b07a63f 100644 --- a/regcomp.h +++ b/regcomp.h @@ -463,6 +463,8 @@ EXTCONST regexp_engine PL_core_reg_engine = { Perl_re_intuit_start, Perl_re_intuit_string, Perl_regfree_internal, + Perl_reg_numbered_buff_get, + Perl_reg_named_buff_get, #if defined(USE_ITHREADS) Perl_regdupe_internal #endif diff --git a/regexp.h b/regexp.h index d43f05f..68dd547 100644 --- a/regexp.h +++ b/regexp.h @@ -111,6 +111,8 @@ typedef struct regexp_engine { struct re_scream_pos_data_s *data); SV* (*checkstr) (pTHX_ regexp *prog); void (*free) (pTHX_ struct regexp* r); + SV* (*numbered_buff_get) (pTHX_ const REGEXP * const rx, I32 paren, SV* usesv); + SV* (*named_buff_get)(pTHX_ const REGEXP * const rx, SV* namesv, U32 flags); #ifdef USE_ITHREADS void* (*dupe) (pTHX_ const regexp *r, CLONE_PARAMS *param); #endif