Skip to content

Commit

Permalink
FETCH/STORE/LENGTH callbacks for numbered capture variables
Browse files Browse the repository at this point in the history 
From: "Ævar Arnfjörð Bjarmason" <avarab@gmail.com>
Message-ID: <51dd1af80705011658g1156e14cw4d2b21a8d772ed41@mail.gmail.com>

p4raw-id: //depot/perl@31130
  • Loading branch information
@rgs
Ævar Arnfjörð Bjarmason authored and rgs committed May 3, 2007
1 parent b37a2be commit 2fdbfb4
Show file tree
Hide file tree
Showing 15 changed files with 345 additions and 132 deletions.
8 changes: 6 additions & 2 deletions embed.fnc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -694,8 +694,12 @@ Ap |I32 |regexec_flags |NN REGEXP * const rx|NN char* stringarg \
|NN SV* screamer|NULLOK void* data|U32 flags
ApR |regnode*|regnext |NN regnode* p

EXp |SV*|reg_named_buff_get |NN REGEXP * const rx|NN SV * const namesv|const U32 flags
EXp |void|reg_numbered_buff_get|NN REGEXP * const rx|const I32 paren|NULLOK SV * const usesv
EXp |SV*|reg_named_buff_fetch |NN REGEXP * const rx|NN SV * const key|const U32 flags

EXp |void|reg_numbered_buff_fetch|NN REGEXP * const rx|const I32 paren|NULLOK SV * const sv
EXp |void|reg_numbered_buff_store|NN REGEXP * const rx|const I32 paren|NULLOK SV const * const value
EXp |I32|reg_numbered_buff_length|NN REGEXP * const rx|NN const SV * const sv|const I32 paren

EXp |SV*|reg_qr_package|NN REGEXP * const rx

Ep |void |regprop |NULLOK const regexp *prog|NN SV* sv|NN const regnode* o
Expand Down
20 changes: 16 additions & 4 deletions embed.h
View file
Original file line number Diff line number Diff line change
Expand Up @@ -704,8 +704,14 @@
#define regexec_flags Perl_regexec_flags
#define regnext Perl_regnext
#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
#define reg_named_buff_fetch Perl_reg_named_buff_fetch
#endif
#if defined(PERL_CORE) || defined(PERL_EXT)
#define reg_numbered_buff_fetch Perl_reg_numbered_buff_fetch
#define reg_numbered_buff_store Perl_reg_numbered_buff_store
#define reg_numbered_buff_length Perl_reg_numbered_buff_length
#endif
#if defined(PERL_CORE) || defined(PERL_EXT)
#define reg_qr_package Perl_reg_qr_package
#endif
#if defined(PERL_CORE) || defined(PERL_EXT)
Expand Down Expand Up @@ -2972,8 +2978,14 @@
#define regexec_flags(a,b,c,d,e,f,g,h) Perl_regexec_flags(aTHX_ a,b,c,d,e,f,g,h)
#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) Perl_reg_numbered_buff_get(aTHX_ a,b,c)
#define reg_named_buff_fetch(a,b,c) Perl_reg_named_buff_fetch(aTHX_ a,b,c)
#endif
#if defined(PERL_CORE) || defined(PERL_EXT)
#define reg_numbered_buff_fetch(a,b,c) Perl_reg_numbered_buff_fetch(aTHX_ a,b,c)
#define reg_numbered_buff_store(a,b,c) Perl_reg_numbered_buff_store(aTHX_ a,b,c)
#define reg_numbered_buff_length(a,b,c) Perl_reg_numbered_buff_length(aTHX_ a,b,c)
#endif
#if defined(PERL_CORE) || defined(PERL_EXT)
#define reg_qr_package(a) Perl_reg_qr_package(aTHX_ a)
#endif
#if defined(PERL_CORE) || defined(PERL_EXT)
Expand Down
16 changes: 12 additions & 4 deletions ext/re/re.xs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -22,10 +22,16 @@ extern char* my_re_intuit_start (pTHX_ REGEXP * const prog, SV *sv, char *strpos
extern SV* my_re_intuit_string (pTHX_ REGEXP * const prog);

extern void my_regfree (pTHX_ REGEXP * const r);
extern void my_reg_numbered_buff_get(pTHX_ REGEXP * const rx, const I32 paren,

extern void my_reg_numbered_buff_fetch(pTHX_ REGEXP * const rx, const I32 paren,
SV * const usesv);
extern SV* my_reg_named_buff_get(pTHX_ REGEXP * const rx, SV * const namesv,
extern void my_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
SV const * const value);
extern I32 my_reg_numbered_buff_length(pTHX_ REGEXP * const rx, const I32 paren);

extern SV* my_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const key,
const U32 flags);

extern SV* my_reg_qr_package(pTHX_ REGEXP * const rx);
#if defined(USE_ITHREADS)
extern void* my_regdupe (pTHX_ REGEXP * const r, CLONE_PARAMS *param);
Expand All @@ -41,8 +47,10 @@ 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,
my_reg_numbered_buff_fetch,
my_reg_numbered_buff_store,
my_reg_numbered_buff_length,
my_reg_named_buff_fetch,
my_reg_qr_package,
#if defined(USE_ITHREADS)
my_regdupe
Expand Down
6 changes: 4 additions & 2 deletions ext/re/re_top.h
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16,8 +16,10 @@
#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_reg_numbered_buff_fetch my_reg_numbered_buff_fetch
#define Perl_reg_numbered_buff_store my_reg_numbered_buff_store
#define Perl_reg_numbered_buff_length my_reg_numbered_buff_length
#define Perl_reg_named_buff_fetch my_reg_named_buff_fetch
#define Perl_reg_qr_package my_reg_qr_package

#define PERL_NO_GET_CONTEXT
Expand Down
6 changes: 4 additions & 2 deletions global.sym
View file
Original file line number Diff line number Diff line change
Expand Up @@ -405,8 +405,10 @@ Perl_re_intuit_start
Perl_re_intuit_string
Perl_regexec_flags
Perl_regnext
Perl_reg_named_buff_get
Perl_reg_numbered_buff_get
Perl_reg_named_buff_fetch
Perl_reg_numbered_buff_fetch
Perl_reg_numbered_buff_store
Perl_reg_numbered_buff_length
Perl_reg_qr_package
Perl_repeatcpy
Perl_rninstr
Expand Down
22 changes: 11 additions & 11 deletions gv.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1127,14 +1127,14 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
break;
case '\015': /* $^MATCH */
if (strEQ(name2, "ATCH"))
goto ro_magicalize;
goto magicalize;
case '\017': /* $^OPEN */
if (strEQ(name2, "PEN"))
goto magicalize;
break;
case '\020': /* $^PREMATCH $^POSTMATCH */
if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH"))
goto ro_magicalize;
goto magicalize;
case '\024': /* ${^TAINT} */
if (strEQ(name2, "AINT"))
goto ro_magicalize;
Expand All @@ -1161,14 +1161,14 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
case '8':
case '9':
{
/* ensures variable is only digits */
/* ${"1foo"} fails this test (and is thus writeable) */
/* added by japhy, but borrowed from is_gv_magical */
/* Ensures that we have an all-digit variable, ${"1foo"} fails
this test */
/* This snippet is taken from is_gv_magical */
const char *end = name + len;
while (--end > name) {
if (!isDIGIT(*end)) return gv;
if (!isDIGIT(*end)) return gv;
}
goto ro_magicalize;
goto magicalize;
}
}
}
Expand All @@ -1187,7 +1187,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
sv_type == SVt_PVIO
) { break; }
PL_sawampersand = TRUE;
goto ro_magicalize;
goto magicalize;

case ':':
sv_setpv(GvSVn(gv),PL_chopset);
Expand Down Expand Up @@ -1245,6 +1245,9 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
}
goto magicalize;
case '\023': /* $^S */
ro_magicalize:
SvREADONLY_on(GvSVn(gv));
/* FALL THROUGH */
case '1':
case '2':
case '3':
Expand All @@ -1254,9 +1257,6 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
case '7':
case '8':
case '9':
ro_magicalize:
SvREADONLY_on(GvSVn(gv));
/* FALL THROUGH */
case '[':
case '^':
case '~':
Expand Down
145 changes: 84 additions & 61 deletions mg.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -582,45 +582,53 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
dVAR;
register I32 paren;
register I32 i;
register const REGEXP *rx;
I32 s1, t1;
register const REGEXP * rx;
const char * const remaining = mg->mg_ptr + 1;

switch (*mg->mg_ptr) {
case '\020':
if (*remaining == '\0') { /* ^P */
break;
} else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
goto do_prematch;
} else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
goto do_postmatch;
}
break;
case '\015': /* $^MATCH */
if (strEQ(remaining, "ATCH")) {
goto do_match;
} else {
break;
}
case '`':
do_prematch:
paren = -2;
goto maybegetparen;
case '\'':
do_postmatch:
paren = -1;
goto maybegetparen;
case '&':
do_match:
paren = 0;
goto maybegetparen;
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9': case '&':
case '5': case '6': case '7': case '8': case '9':
paren = atoi(mg->mg_ptr);
maybegetparen:
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
getparen:
i = CALLREG_NUMBUF_LENGTH((REGEXP * const)rx, sv, paren);

paren = atoi(mg->mg_ptr); /* $& is in [0] */
getparen:
if (paren <= (I32)rx->nparens &&
(s1 = rx->offs[paren].start) != -1 &&
(t1 = rx->offs[paren].end) != -1)
{
i = t1 - s1;
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;
}
if (i < 0)
Perl_croak(aTHX_ "panic: magic_len: %"IVdf, (IV)i);
return i;
}
else {
} else {
if (ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
}
}
else {
if (ckWARN(WARN_UNINITIALIZED))
report_uninit(sv);
return 0;
}
return 0;
case '+':
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
paren = rx->lastparen;
Expand All @@ -635,30 +643,6 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
goto getparen;
}
return 0;
case '`':
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
if (rx->offs[0].start != -1) {
i = rx->offs[0].start;
if (i > 0) {
s1 = 0;
t1 = i;
goto getlen;
}
}
}
return 0;
case '\'':
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
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;
}
magic_get(sv,mg);
if (!SvPOK(sv) && SvNIOK(sv)) {
Expand Down Expand Up @@ -896,7 +880,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
* XXX Does the new way break anything?
*/
paren = atoi(mg->mg_ptr); /* $& is in [0] */
CALLREG_NUMBUF(rx,paren,sv);
CALLREG_NUMBUF_FETCH(rx,paren,sv);
break;
}
sv_setsv(sv,&PL_sv_undef);
Expand All @@ -905,7 +889,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
case '+':
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
if (rx->lastparen) {
CALLREG_NUMBUF(rx,rx->lastparen,sv);
CALLREG_NUMBUF_FETCH(rx,rx->lastparen,sv);
break;
}
}
Expand All @@ -914,7 +898,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
case '\016': /* ^N */
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
if (rx->lastcloseparen) {
CALLREG_NUMBUF(rx,rx->lastcloseparen,sv);
CALLREG_NUMBUF_FETCH(rx,rx->lastcloseparen,sv);
break;
}

Expand All @@ -924,15 +908,15 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
case '`':
do_prematch_fetch:
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
CALLREG_NUMBUF(rx,-2,sv);
CALLREG_NUMBUF_FETCH(rx,-2,sv);
break;
}
sv_setsv(sv,&PL_sv_undef);
break;
case '\'':
do_postmatch_fetch:
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
CALLREG_NUMBUF(rx,-1,sv);
CALLREG_NUMBUF_FETCH(rx,-1,sv);
break;
}
sv_setsv(sv,&PL_sv_undef);
Expand Down Expand Up @@ -2234,9 +2218,42 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
{
dVAR;
register const char *s;
register I32 paren;
register const REGEXP * rx;
const char * const remaining = mg->mg_ptr + 1;
I32 i;
STRLEN len;

switch (*mg->mg_ptr) {
case '\015': /* $^MATCH */
if (strEQ(remaining, "ATCH"))
goto do_match;
case '`': /* ${^PREMATCH} caught below */
do_prematch:
paren = -2;
goto setparen;
case '\'': /* ${^POSTMATCH} caught below */
do_postmatch:
paren = -1;
goto setparen;
case '&':
do_match:
paren = 0;
goto setparen;
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
setparen:
if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
break;
} else {
/* Croak with a READONLY error when a numbered match var is
* set without a previous pattern match. Unless it's C<local $1>
*/
if (!PL_localizing) {
Perl_croak(aTHX_ PL_no_modify);
}
}
case '\001': /* ^A */
sv_setsv(PL_bodytarget, sv);
break;
Expand Down Expand Up @@ -2335,10 +2352,16 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
}
break;
case '\020': /* ^P */
PL_perldb = SvIV(sv);
if (PL_perldb && !PL_DBsingle)
init_debugger();
break;
if (*remaining == '\0') { /* ^P */
PL_perldb = SvIV(sv);
if (PL_perldb && !PL_DBsingle)
init_debugger();
break;
} else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */
goto do_prematch;
} else if (strEQ(remaining, "OSTMATCH")) { /* $^POSTMATCH */
goto do_postmatch;
}
case '\024': /* ^T */
#ifdef BIG_TIME
PL_basetime = (Time_t)(SvNOK(sv) ? SvNVX(sv) : sv_2nv(sv));
Expand Down
Loading

0 comments on commit 2fdbfb4

Please sign in to comment.