and regexp reference counting is via the regular SV reference counting.
This was not as easy at it looks.
p4raw-id: //depot/perl@32804
'') ;;
[12]*) ;; # gcc versions 1 (gasp!) and 2 are not good for this.
Intel*) ;; # # Is that you, Intel C++?
-*) for opt in -ansi -pedantic -std=c89 -W -Wextra -Wdeclaration-after-statement -Wendif-labels -Wc++-compat
+*) for opt in -ansi -std=c89 -W -Wextra -Wdeclaration-after-statement -Wendif-labels -Wc++-compat
do
case " $ccflags " in
*" $opt "*) ;; # Skip if already there.
Perl_dump_indent(aTHX_ level, file, " PV = 0\n");
}
if (type == SVt_REGEXP) {
+ /* FIXME dumping
Perl_dump_indent(aTHX_ level, file, " REGEXP = 0x%"UVxf"\n",
- PTR2UV(((struct xregexp *)SvANY(sv))->xrx_regexp));
+ PTR2UV(((struct regexp *)SvANY(sv))->xrx_regexp));
+ */
}
if (type >= SVt_PVMG) {
if (type == SVt_PVMG && SvPAD_OUR(sv)) {
p |int |magic_clearpack|NN SV* sv|NN MAGIC* mg
p |int |magic_clearsig |NN SV* sv|NN MAGIC* mg
p |int |magic_existspack|NN SV* sv|NN const MAGIC* mg
-p |int |magic_freeregexp|NN SV* sv|NN MAGIC* mg
p |int |magic_freeovrld|NN SV* sv|NN MAGIC* mg
p |int |magic_get |NN SV* sv|NN MAGIC* mg
p |int |magic_getarylen|NN SV* sv|NN const MAGIC* mg
|NN char* strend|NN char* strbeg|I32 minend \
|NN SV* screamer|U32 nosave
Ap |void |pregfree |NULLOK REGEXP* r
+Ap |void |pregfree2 |NN REGEXP* prog
EXp |REGEXP*|reg_temp_copy |NN REGEXP* r
Ap |void |regfree_internal|NULLOK REGEXP * const r
Ap |char * |reg_stringify |NN MAGIC *mg|NULLOK STRLEN *lp|NULLOK U32 *flags|NULLOK I32 *haseval
ApR |void* |any_dup |NULLOK void* v|NN const PerlInterpreter* proto_perl
ApR |HE* |he_dup |NULLOK const HE* e|bool shared|NN CLONE_PARAMS* param
ApR |HEK* |hek_dup |NULLOK HEK* e|NN CLONE_PARAMS* param
-ApR |REGEXP*|re_dup |NULLOK const REGEXP* r|NN CLONE_PARAMS* param
+Ap |void |re_dup_guts |NN const REGEXP *sstr|NN REGEXP *dstr \
+ |NN CLONE_PARAMS* param
Ap |PerlIO*|fp_dup |NULLOK PerlIO* fp|char type|NN CLONE_PARAMS* param
ApR |DIR* |dirp_dup |NULLOK DIR* dp
ApR |GP* |gp_dup |NULLOK GP* gp|NN CLONE_PARAMS* param
#define magic_clearpack Perl_magic_clearpack
#define magic_clearsig Perl_magic_clearsig
#define magic_existspack Perl_magic_existspack
-#define magic_freeregexp Perl_magic_freeregexp
#define magic_freeovrld Perl_magic_freeovrld
#define magic_get Perl_magic_get
#define magic_getarylen Perl_magic_getarylen
#define regclass_swash Perl_regclass_swash
#define pregexec Perl_pregexec
#define pregfree Perl_pregfree
+#define pregfree2 Perl_pregfree2
#if defined(PERL_CORE) || defined(PERL_EXT)
#define reg_temp_copy Perl_reg_temp_copy
#endif
#define any_dup Perl_any_dup
#define he_dup Perl_he_dup
#define hek_dup Perl_hek_dup
-#define re_dup Perl_re_dup
+#define re_dup_guts Perl_re_dup_guts
#define fp_dup Perl_fp_dup
#define dirp_dup Perl_dirp_dup
#define gp_dup Perl_gp_dup
#define magic_clearpack(a,b) Perl_magic_clearpack(aTHX_ a,b)
#define magic_clearsig(a,b) Perl_magic_clearsig(aTHX_ a,b)
#define magic_existspack(a,b) Perl_magic_existspack(aTHX_ a,b)
-#define magic_freeregexp(a,b) Perl_magic_freeregexp(aTHX_ a,b)
#define magic_freeovrld(a,b) Perl_magic_freeovrld(aTHX_ a,b)
#define magic_get(a,b) Perl_magic_get(aTHX_ a,b)
#define magic_getarylen(a,b) Perl_magic_getarylen(aTHX_ a,b)
#define regclass_swash(a,b,c,d,e) Perl_regclass_swash(aTHX_ a,b,c,d,e)
#define pregexec(a,b,c,d,e,f,g) Perl_pregexec(aTHX_ a,b,c,d,e,f,g)
#define pregfree(a) Perl_pregfree(aTHX_ a)
+#define pregfree2(a) Perl_pregfree2(aTHX_ a)
#if defined(PERL_CORE) || defined(PERL_EXT)
#define reg_temp_copy(a) Perl_reg_temp_copy(aTHX_ a)
#endif
#define any_dup(a,b) Perl_any_dup(aTHX_ a,b)
#define he_dup(a,b,c) Perl_he_dup(aTHX_ a,b,c)
#define hek_dup(a,b) Perl_hek_dup(aTHX_ a,b)
-#define re_dup(a,b) Perl_re_dup(aTHX_ a,b)
+#define re_dup_guts(a,b,c) Perl_re_dup_guts(aTHX_ a,b,c)
#define fp_dup(a,b,c) Perl_fp_dup(aTHX_ a,b,c)
#define dirp_dup(a) Perl_dirp_dup(aTHX_ a)
#define gp_dup(a,b) Perl_gp_dup(aTHX_ a,b)
REGEX(sv)
B::REGEXP sv
CODE:
- RETVAL = PTR2IV(((struct xregexp *)SvANY(sv))->xrx_regexp);
+ /* FIXME - can we code this method more efficiently? */
+ RETVAL = PTR2IV(sv);
OUTPUT:
RETVAL
SV*
precomp(sv)
B::REGEXP sv
- REGEXP* rx = NO_INIT
CODE:
- rx = ((struct xregexp *)SvANY(sv))->xrx_regexp;
- /* FIXME - UTF-8? And the equivalent precomp methods? */
- RETVAL = newSVpvn( RX_PRECOMP(rx), RX_PRELEN(rx) );
+ RETVAL = newSVpvn( RX_PRECOMP(sv), RX_PRELEN(sv) );
OUTPUT:
RETVAL
FLAGS = \\(ROK\\)
RV = $ADDR
SV = REGEXP\\($ADDR\\) at $ADDR
- REFCNT = 1
+ REFCNT = 2
FLAGS = \\(\\)
IV = 0
NV = 0
- PV = 0
- REGEXP = $ADDR');
+ PV = 0');
} else {
do_test(15,
qr(tic),
return sv_unmagic(sv, type);
}
-int
-Perl_magic_freeregexp(pTHX_ SV *sv, MAGIC *mg)
-{
- dVAR;
- regexp * const re = (regexp *)mg->mg_obj;
- PERL_UNUSED_ARG(sv);
-
- ReREFCNT_dec(re);
- return 0;
-}
-
#ifdef USE_LOCALE_COLLATE
int
Perl_magic_setcollxfrm(pTHX_ SV *sv, MAGIC *mg)
typedef struct av AV;
typedef struct hv HV;
typedef struct cv CV;
-typedef struct regexp REGEXP;
+typedef struct regexp ORANGE; /* This is the body structure. */
+typedef SV REGEXP;
typedef struct gp GP;
typedef struct gv GV;
typedef struct io IO;
};
#endif
-#include "regexp.h"
#include "sv.h"
+#include "regexp.h"
#include "util.h"
#include "form.h"
#include "gv.h"
MEMBER_TO_FPTR(Perl_magic_setregexp),
0,
0,
- MEMBER_TO_FPTR(Perl_magic_freeregexp),
+ 0,
0,
0,
0
if (SvROK(tmpstr)) {
SV * const sv = SvRV(tmpstr);
if (SvTYPE(sv) == SVt_REGEXP)
- re = ((struct xregexp *)SvANY(sv))->xrx_regexp;
+ re = sv;
}
if (re) {
re = reg_temp_copy(re);
# define SM_REGEX ( \
(SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP) \
- && (this_regex = ((struct xregexp *)SvANY(This))->xrx_regexp) \
+ && (this_regex = This) \
&& (Other = e)) \
|| \
(SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP) \
- && (this_regex = ((struct xregexp *)SvANY(This))->xrx_regexp) \
+ && (this_regex = This) \
&& (Other = d)) )
# define SM_OTHER_REGEX (SvROK(Other) \
&& (SvTYPE(SvRV(Other)) == SVt_REGEXP) \
- && (other_regex = ((struct xregexp *)SvANY(SvRV(Other)))->xrx_regexp))
+ && (other_regex = SvRV(Other)))
# define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
REGEXP * rx = PM_GETRE(pm);
SV * const pkg = CALLREG_PACKAGE(rx);
SV * const rv = sv_newmortal();
- SV * const sv = newSVrv(rv, pkg ? SvPV_nolen(pkg) : NULL);
+
+ SvUPGRADE(rv, SVt_IV);
+ /* This RV is about to own a reference to the regexp. (In addition to the
+ reference already owned by the PMOP. */
+ ReREFCNT_inc(rx);
+ SvRV_set(rv, rx);
+ SvROK_on(rv);
+
+ if (pkg) {
+ HV* const stash = gv_stashpv(SvPV_nolen(pkg), GV_ADD);
+ (void)sv_bless(rv, stash);
+ }
+
if (RX_EXTFLAGS(rx) & RXf_TAINTED)
SvTAINTED_on(rv);
- sv_upgrade(sv, SVt_REGEXP);
- ((struct xregexp *)SvANY(sv))->xrx_regexp = ReREFCNT_inc(rx);
XPUSHs(rv);
RETURN;
}
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
-PERL_CALLCONV int Perl_magic_freeregexp(pTHX_ SV* sv, MAGIC* mg)
- __attribute__nonnull__(pTHX_1)
- __attribute__nonnull__(pTHX_2);
-
PERL_CALLCONV int Perl_magic_freeovrld(pTHX_ SV* sv, MAGIC* mg)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
__attribute__nonnull__(pTHX_6);
PERL_CALLCONV void Perl_pregfree(pTHX_ REGEXP* r);
+PERL_CALLCONV void Perl_pregfree2(pTHX_ REGEXP* prog)
+ __attribute__nonnull__(pTHX_1);
+
PERL_CALLCONV REGEXP* Perl_reg_temp_copy(pTHX_ REGEXP* r)
__attribute__nonnull__(pTHX_1);
__attribute__warn_unused_result__
__attribute__nonnull__(pTHX_2);
-PERL_CALLCONV REGEXP* Perl_re_dup(pTHX_ const REGEXP* r, CLONE_PARAMS* param)
- __attribute__warn_unused_result__
- __attribute__nonnull__(pTHX_2);
+PERL_CALLCONV void Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS* param)
+ __attribute__nonnull__(pTHX_1)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_3);
PERL_CALLCONV PerlIO* Perl_fp_dup(pTHX_ PerlIO* fp, char type, CLONE_PARAMS* param)
__attribute__nonnull__(pTHX_3);
typedef struct RExC_state_t {
U32 flags; /* are we folding, multilining? */
char *precomp; /* uncompiled string. */
+ REGEXP *rx_sv; /* The SV that is the regexp. */
regexp *rx; /* perl core regexp structure */
regexp_internal *rxi; /* internal data for regexp object pprivate field */
char *start; /* Start of input for compile */
#define RExC_flags (pRExC_state->flags)
#define RExC_precomp (pRExC_state->precomp)
+#define RExC_rx_sv (pRExC_state->rx_sv)
#define RExC_rx (pRExC_state->rx)
#define RExC_rxi (pRExC_state->rxi)
#define RExC_start (pRExC_state->start)
IV len = RExC_end - RExC_precomp; \
\
if (!SIZE_ONLY) \
- SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \
+ SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \
if (len > RegexLengthToShowInErrorMessages) { \
/* chop 10 shorter than the max, to ensure meaning of "..." */ \
len = RegexLengthToShowInErrorMessages - 10; \
*/
#define vFAIL(m) STMT_START { \
if (!SIZE_ONLY) \
- SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \
+ SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \
Simple_vFAIL(m); \
} STMT_END
*/
#define vFAIL2(m,a1) STMT_START { \
if (!SIZE_ONLY) \
- SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \
+ SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \
Simple_vFAIL2(m, a1); \
} STMT_END
*/
#define vFAIL3(m,a1,a2) STMT_START { \
if (!SIZE_ONLY) \
- SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \
+ SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \
Simple_vFAIL3(m, a1, a2); \
} STMT_END
Perl_re_compile(pTHX_ const SV * const pattern, const U32 pm_flags)
{
dVAR;
- register REGEXP *r;
+ REGEXP *rx;
+ struct regexp *r;
register regexp_internal *ri;
STRLEN plen;
char* exp = SvPV((SV*)pattern, plen);
/* Allocate space and zero-initialize. Note, the two step process
of zeroing when in debug mode, thus anything assigned has to
happen after that */
- Newxz(r, 1, regexp);
+ rx = newSV_type(SVt_REGEXP);
+ r = (struct regexp*)SvANY(rx);
Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
char, regexp_internal);
if ( r == NULL || ri == NULL )
/* non-zero initialization begins here */
RXi_SET( r, ri );
r->engine= RE_ENGINE_PTR;
- r->refcnt = 1;
r->extflags = pm_flags;
{
bool has_p = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
(UV)((2*RExC_size+1) * sizeof(U32))));
#endif
SetProgLen(ri,RExC_size);
+ RExC_rx_sv = rx;
RExC_rx = r;
RExC_rxi = ri;
RExC_rx->seen_evals = RExC_seen_evals;
REGC((U8)REG_MAGIC, (char*) RExC_emit++);
if (reg(pRExC_state, 0, &flags,1) == NULL) {
- ReREFCNT_dec(r);
+ ReREFCNT_dec(rx);
return(NULL);
}
/* XXXX To minimize changes to RE engine we always allocate
PerlIO_printf(Perl_debug_log, "\n");
});
#endif
- return(r);
+ return rx;
}
#undef RE_ENGINE_PTR
}
SV*
-Perl_reg_named_buff_fetch(pTHX_ REGEXP * const rx, SV * const namesv, const U32 flags)
+Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
+ const U32 flags)
{
AV *retarray = NULL;
SV *ret;
+ struct regexp *const rx = (struct regexp *)SvANY(r);
if (flags & RXapif_ALL)
retarray=newAV();
&& rx->offs[nums[i]].end != -1)
{
ret = newSVpvs("");
- CALLREG_NUMBUF_FETCH(rx,nums[i],ret);
+ CALLREG_NUMBUF_FETCH(r,nums[i],ret);
if (!retarray)
return ret;
} else {
}
bool
-Perl_reg_named_buff_exists(pTHX_ REGEXP * const rx, SV * const key,
+Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
const U32 flags)
{
+ struct regexp *const rx = (struct regexp *)SvANY(r);
if (rx && rx->paren_names) {
if (flags & RXapif_ALL) {
return hv_exists_ent(rx->paren_names, key, 0);
} else {
- SV *sv = CALLREG_NAMED_BUFF_FETCH(rx, key, flags);
+ SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
if (sv) {
SvREFCNT_dec(sv);
return TRUE;
}
SV*
-Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const rx, const U32 flags)
+Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
{
+ struct regexp *const rx = (struct regexp *)SvANY(r);
if ( rx && rx->paren_names ) {
(void)hv_iterinit(rx->paren_names);
- return CALLREG_NAMED_BUFF_NEXTKEY(rx, NULL, flags & ~RXapif_FIRSTKEY);
+ return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
} else {
return FALSE;
}
}
SV*
-Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const rx, const U32 flags)
+Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
{
+ struct regexp *const rx = (struct regexp *)SvANY(r);
if (rx && rx->paren_names) {
HV *hv = rx->paren_names;
HE *temphe;
}
SV*
-Perl_reg_named_buff_scalar(pTHX_ REGEXP * const rx, const U32 flags)
+Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
{
SV *ret;
AV *av;
I32 length;
+ struct regexp *const rx = (struct regexp *)SvANY(r);
if (rx && rx->paren_names) {
if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
return newSViv(HvTOTALKEYS(rx->paren_names));
} else if (flags & RXapif_ONE) {
- ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES));
+ ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
av = (AV*)SvRV(ret);
length = av_len(av);
return newSViv(length + 1);
}
SV*
-Perl_reg_named_buff_all(pTHX_ REGEXP * const rx, const U32 flags)
+Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
{
+ struct regexp *const rx = (struct regexp *)SvANY(r);
AV *av = newAV();
if (rx && rx->paren_names) {
}
void
-Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const rx, const I32 paren, SV * const sv)
+Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
+ SV * const sv)
{
+ struct regexp *const rx = (struct regexp *)SvANY(r);
char *s = NULL;
I32 i = 0;
I32 s1, t1;
}
I32
-Perl_reg_numbered_buff_length(pTHX_ REGEXP * const rx, const SV * const sv,
+Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
const I32 paren)
{
+ struct regexp *const rx = (struct regexp *)SvANY(r);
I32 i;
I32 s1, t1;
}
SV *
-Perl_re_intuit_string(pTHX_ REGEXP * const prog)
+Perl_re_intuit_string(pTHX_ REGEXP * const r)
{ /* Assume that RE_INTUIT is set */
dVAR;
+ struct regexp *const prog = (struct regexp *)SvANY(r);
GET_RE_DEBUG_FLAGS_DECL;
PERL_UNUSED_CONTEXT;
void
Perl_pregfree(pTHX_ REGEXP *r)
{
+ SvREFCNT_dec(r);
+}
+
+void
+Perl_pregfree2(pTHX_ REGEXP *rx)
+{
dVAR;
+ struct regexp *const r = (struct regexp *)SvANY(rx);
GET_RE_DEBUG_FLAGS_DECL;
- if (!r || (--r->refcnt > 0))
- return;
if (r->mother_re) {
ReREFCNT_dec(r->mother_re);
} else {
- CALLREGFREE_PVT(r); /* free the private data */
+ CALLREGFREE_PVT(rx); /* free the private data */
if (r->paren_names)
SvREFCNT_dec(r->paren_names);
Safefree(RXp_WRAPPED(r));
SvREFCNT_dec(r->float_utf8);
Safefree(r->substrs);
}
- RX_MATCH_COPY_FREE(r);
+ RX_MATCH_COPY_FREE(rx);
#ifdef PERL_OLD_COPY_ON_WRITE
if (r->saved_copy)
SvREFCNT_dec(r->saved_copy);
#endif
Safefree(r->swap);
Safefree(r->offs);
- Safefree(r);
}
/* reg_temp_copy()
REGEXP *
-Perl_reg_temp_copy (pTHX_ REGEXP *r) {
- regexp *ret;
+Perl_reg_temp_copy (pTHX_ REGEXP *rx) {
+ REGEXP *ret_x = newSV_type(SVt_REGEXP);
+ struct regexp *ret = (struct regexp *)SvANY(ret_x);
+ struct regexp *const r = (struct regexp *)SvANY(rx);
register const I32 npar = r->nparens+1;
- (void)ReREFCNT_inc(r);
- Newx(ret, 1, regexp);
+ (void)ReREFCNT_inc(rx);
+ /* FIXME ORANGE (once we start actually using the regular SV fields.) */
StructCopy(r, ret, regexp);
Newx(ret->offs, npar, regexp_paren_pair);
Copy(r->offs, ret->offs, npar, regexp_paren_pair);
- ret->refcnt = 1;
if (r->substrs) {
Newx(ret->substrs, 1, struct reg_substr_data);
StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
/* check_substr and check_utf8, if non-NULL, point to either their
anchored or float namesakes, and don't hold a second reference. */
}
- RX_MATCH_COPIED_off(ret);
+ RX_MATCH_COPIED_off(ret_x);
#ifdef PERL_OLD_COPY_ON_WRITE
ret->saved_copy = NULL;
#endif
- ret->mother_re = r;
+ ret->mother_re = rx;
ret->swap = NULL;
- return ret;
+ return ret_x;
}
#endif
*/
void
-Perl_regfree_internal(pTHX_ REGEXP * const r)
+Perl_regfree_internal(pTHX_ REGEXP * const rx)
{
dVAR;
+ struct regexp *const r = (struct regexp *)SvANY(rx);
RXi_GET_DECL(r,ri);
GET_RE_DEBUG_FLAGS_DECL;
*/
#if defined(USE_ITHREADS)
#ifndef PERL_IN_XSUB_RE
-regexp *
-Perl_re_dup(pTHX_ const regexp *r, CLONE_PARAMS *param)
+void
+Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
{
dVAR;
- regexp *ret;
I32 npar;
-
- if (!r)
- return (REGEXP *)NULL;
-
- if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
- return ret;
-
+ const struct regexp *r = (const struct regexp *)SvANY(sstr);
+ struct regexp *ret = (struct regexp *)SvANY(dstr);
npar = r->nparens+1;
- Newx(ret, 1, regexp);
- StructCopy(r, ret, regexp);
Newx(ret->offs, npar, regexp_paren_pair);
Copy(r->offs, ret->offs, npar, regexp_paren_pair);
if(ret->swap) {
ret->paren_names = hv_dup_inc(ret->paren_names, param);
if (ret->pprivate)
- RXi_SET(ret,CALLREGDUPE_PVT(ret,param));
+ RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
- if (RX_MATCH_COPIED(ret))
+ if (RX_MATCH_COPIED(dstr))
ret->subbeg = SAVEPVN(ret->subbeg, ret->sublen);
else
ret->subbeg = NULL;
ret->mother_re = NULL;
ret->gofs = 0;
ret->seen_evals = 0;
-
- ptr_table_store(PL_ptr_table, r, ret);
- return ret;
}
#endif /* PERL_IN_XSUB_RE */
*/
void *
-Perl_regdupe_internal(pTHX_ REGEXP * const r, CLONE_PARAMS *param)
+Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
{
dVAR;
+ struct regexp *const r = (struct regexp *)SvANY(rx);
regexp_internal *reti;
int len, npar;
RXi_GET_DECL(r,ri);
#define check_offset_max substrs->data[2].max_offset
#define check_end_shift substrs->data[2].end_shift
-#define RX_ANCHORED_SUBSTR(rx) ((rx)->anchored_substr)
-#define RX_ANCHORED_UTF8(rx) ((rx)->anchored_utf8)
-#define RX_FLOAT_SUBSTR(rx) ((rx)->float_substr)
-#define RX_FLOAT_UTF8(rx) ((rx)->float_utf8)
+#define RX_ANCHORED_SUBSTR(rx) (((struct regexp *)SvANY(rx))->anchored_substr)
+#define RX_ANCHORED_UTF8(rx) (((struct regexp *)SvANY(rx))->anchored_utf8)
+#define RX_FLOAT_SUBSTR(rx) (((struct regexp *)SvANY(rx))->float_substr)
+#define RX_FLOAT_UTF8(rx) (((struct regexp *)SvANY(rx))->float_utf8)
/* trie related stuff */
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) {
PL_reg_flags |= RF_utf8;
- 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,
"Matching");
} 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;
}
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);
/* 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;
}
#endif
}
- PM_SETRE(PL_reg_curpm, prog);
+ PM_SETRE(PL_reg_curpm, rx);
PL_reg_oldcurpm = PL_curpm;
PL_curpm = PL_reg_curpm;
if (RXp_MATCH_COPIED(prog)) {
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;
#define ST st->u.eval
{
SV *ret;
+ SV *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;
- re = NULL;
+ REGEXP *rx = NULL;
if (SvROK(ret)) {
- const SV *const sv = SvRV(ret);
+ SV *const sv = SvRV(ret);
if (SvTYPE(sv) == SVt_REGEXP) {
- re = ((struct xregexp *)SvANY(sv))->xrx_regexp;
+ rx = sv;
} else if (SvSMAGICAL(sv)) {
mg = mg_find(sv, PERL_MAGIC_qr);
assert(mg);
}
} else if (SvTYPE(ret) == SVt_REGEXP) {
- re = ((struct xregexp *)SvANY(ret))->xrx_regexp;
+ rx = ret;
} else if (SvSMAGICAL(ret)) {
if (SvGMAGICAL(ret)) {
/* I don't believe that there is ever qr magic
}
if (mg) {
- re = (regexp *)mg->mg_obj; /*XXX:dmq*/
+ rx = mg->mg_obj; /*XXX:dmq*/
assert(re);
}
- if (re)
- re = reg_temp_copy(re);
+ 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);
+ rx = CALLREGCOMP(ret, pm_flags);
if (!(SvFLAGS(ret)
& (SVs_TEMP | SVs_PADTMP | SVf_READONLY
| 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*)ReREFCNT_inc(re),
- PERL_MAGIC_qr,0,0);
+ sv_magic(ret, rx, PERL_MAGIC_qr, 0, 0);
}
PL_regsize = osize;
}
+ re_sv = rx;
+ re = (struct regexp *)SvANY(rx);
}
RXp_MATCH_COPIED_off(re);
re->subbeg = rex->subbeg;
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;
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_reginput = locinput;
REGCP_UNWIND(ST.lastcp);
= 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;
*/
typedef struct regexp {
+ _XPV_HEAD;
+ _XPVMG_HEAD;
/* what engine created this regexp? */
const struct regexp_engine* engine;
- struct regexp* mother_re; /* what re is this a lightweight copy of? */
+ REGEXP *mother_re; /* what re is this a lightweight copy of? */
/* Information about the match that the perl core uses to manage things */
U32 extflags; /* Flags used both externally and internally */
unsigned pre_prefix:4; /* offset from wrapped to the start of precomp */
unsigned seen_evals:28; /* number of eval groups in the pattern - for security checks */
HV *paren_names; /* Optional hash of paren names */
-
- /* Refcount of this regexp */
- I32 refcnt; /* Refcount of this regexp */
} regexp;
/* used for high speed searches */
#define RXp_EXTFLAGS(rx) ((rx)->extflags)
/* For source compatibility. We used to store these explicitly. */
-#define RX_PRECOMP(prog) ((prog)->wrapped + (prog)->pre_prefix)
-#define RX_PRELEN(prog) ((prog)->wraplen - (prog)->pre_prefix - 1)
-#define RX_WRAPPED(prog) ((prog)->wrapped)
-#define RX_WRAPLEN(prog) ((prog)->wraplen)
-#define RX_CHECK_SUBSTR(prog) ((prog)->check_substr)
-#define RX_EXTFLAGS(prog) ((prog)->extflags)
-#define RX_REFCNT(prog) ((prog)->refcnt)
-#define RX_ENGINE(prog) ((prog)->engine)
-#define RX_SUBBEG(prog) ((prog)->subbeg)
-#define RX_OFFS(prog) ((prog)->offs)
-#define RX_NPARENS(prog) ((prog)->nparens)
-#define RX_SUBLEN(prog) ((prog)->sublen)
-#define RX_SUBBEG(prog) ((prog)->subbeg)
-#define RX_MINLEN(prog) ((prog)->minlen)
-#define RX_MINLENRET(prog) ((prog)->minlenret)
-#define RX_GOFS(prog) ((prog)->gofs)
-#define RX_LASTPAREN(prog) ((prog)->lastparen)
-#define RX_LASTCLOSEPAREN(prog) ((prog)->lastcloseparen)
-#define RX_SEEN_EVALS(prog) ((prog)->seen_evals)
+#define RX_PRECOMP(prog) RXp_PRECOMP((struct regexp *)SvANY(prog))
+#define RX_PRELEN(prog) RXp_PRELEN((struct regexp *)SvANY(prog))
+#define RX_WRAPPED(prog) RXp_WRAPPED((struct regexp *)SvANY(prog))
+#define RX_WRAPLEN(prog) RXp_WRAPLEN((struct regexp *)SvANY(prog))
+#define RX_CHECK_SUBSTR(prog) (((struct regexp *)SvANY(prog))->check_substr)
+#define RX_EXTFLAGS(prog) RXp_EXTFLAGS((struct regexp *)SvANY(prog))
+#define RX_REFCNT(prog) SvREFCNT(prog)
+#define RX_ENGINE(prog) (((struct regexp *)SvANY(prog))->engine)
+#define RX_SUBBEG(prog) (((struct regexp *)SvANY(prog))->subbeg)
+#define RX_OFFS(prog) (((struct regexp *)SvANY(prog))->offs)
+#define RX_NPARENS(prog) (((struct regexp *)SvANY(prog))->nparens)
+#define RX_SUBLEN(prog) (((struct regexp *)SvANY(prog))->sublen)
+#define RX_SUBBEG(prog) (((struct regexp *)SvANY(prog))->subbeg)
+#define RX_MINLEN(prog) (((struct regexp *)SvANY(prog))->minlen)
+#define RX_MINLENRET(prog) (((struct regexp *)SvANY(prog))->minlenret)
+#define RX_GOFS(prog) (((struct regexp *)SvANY(prog))->gofs)
+#define RX_LASTPAREN(prog) (((struct regexp *)SvANY(prog))->lastparen)
+#define RX_LASTCLOSEPAREN(prog) (((struct regexp *)SvANY(prog))->lastcloseparen)
+#define RX_SEEN_EVALS(prog) (((struct regexp *)SvANY(prog))->seen_evals)
#endif /* PLUGGABLE_RE_EXTENSION */
#define REXEC_IGNOREPOS 0x08 /* \G matches at start. */
#define REXEC_NOT_FIRST 0x10 /* This is another iteration of //g. */
-#define ReREFCNT_inc(re) ((void)(re && re->refcnt++), re)
-#define ReREFCNT_dec(re) CALLREGFREE(re)
+#if defined(__GNUC__) && !defined(__STRICT_ANSI__) && !defined(PERL_GCC_PEDANTIC)
+# define ReREFCNT_inc(re) \
+ ({ \
+ /* This is here to generate a casting warning if incorrect. */ \
+ REGEXP *const zwapp = (re); \
+ SvREFCNT_inc(zwapp); \
+ })
+# define ReREFCNT_dec(re) \
+ ({ \
+ /* This is here to generate a casting warning if incorrect. */ \
+ REGEXP *const boff = (re); \
+ SvREFCNT_dec(boff); \
+ })
+#else
+# define ReREFCNT_dec(re) SvREFCNT_dec(re)
+# define ReREFCNT_inc(re) SvREFCNT_inc(re)
+#endif
+
+/* FIXME for plugins. */
#define FBMcf_TAIL_DOLLAR 1
#define FBMcf_TAIL_DOLLARM 2
* Perl_regexec_flags and then passed to regtry(), regmatch() etc */
typedef struct {
- regexp *prog;
+ REGEXP *prog;
char *bol;
char *till;
SV *sv;
struct regmatch_state *prev_yes_state;
struct regmatch_state *prev_eval;
struct regmatch_state *prev_curlyx;
- regexp *prev_rex;
+ REGEXP *prev_rex;
U32 toggle_reg_flags; /* what bits in PL_reg_flags to
flip when transitioning between
inner and outer rexen */
{ sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV,
HASARENA, FIT_ARENA(0, sizeof(XPVMG)) },
- /* 32 */
- { sizeof(struct xregexp), copy_length(struct xregexp, xrx_regexp), 0,
- SVt_REGEXP, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(struct xregexp))
+ /* something big */
+ { sizeof(struct regexp), sizeof(struct regexp), 0,
+ SVt_REGEXP, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(struct regexp))
},
/* 48 */
I32 haseval = 0;
U32 flags = 0;
struct magic temp;
- temp.mg_obj
- = (SV*)((struct xregexp *)SvANY(referent))->xrx_regexp;
+ /* FIXME - get rid of this cast away of const, or work out
+ how to do it better. */
+ temp.mg_obj = (SV *)referent;
assert(temp.mg_obj);
(str) = CALLREG_AS_STR(&temp,lp,&flags,&haseval);
if (flags & 1)
*/
if (!obj || obj == sv ||
how == PERL_MAGIC_arylen ||
- how == PERL_MAGIC_qr ||
how == PERL_MAGIC_symtab ||
(SvTYPE(obj) == SVt_PVGV &&
(GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
Safefree(IoBOTTOM_NAME(sv));
goto freescalar;
case SVt_REGEXP:
- ReREFCNT_dec(((struct xregexp *)SvANY(sv))->xrx_regexp);
+ /* FIXME for plugins */
+ pregfree2(sv);
goto freescalar;
case SVt_PVCV:
case SVt_PVFM:
nmg->mg_private = mg->mg_private;
nmg->mg_type = mg->mg_type;
nmg->mg_flags = mg->mg_flags;
+ /* FIXME for plugins
if (mg->mg_type == PERL_MAGIC_qr) {
nmg->mg_obj = (SV*)CALLREGDUPE((REGEXP*)mg->mg_obj, param);
}
- else if(mg->mg_type == PERL_MAGIC_backref) {
+ else
+ */
+ if(mg->mg_type == PERL_MAGIC_backref) {
/* The backref AV has its reference count deliberately bumped by
1. */
nmg->mg_obj = SvREFCNT_inc(av_dup_inc((AV*) mg->mg_obj, param));
case SVt_PVMG:
break;
case SVt_REGEXP:
- ((struct xregexp *)SvANY(dstr))->xrx_regexp
- = CALLREGDUPE(((struct xregexp *)SvANY(dstr))->xrx_regexp,
- param);
+ /* FIXME for plugins */
+ re_dup_guts(sstr, dstr, param);
break;
case SVt_PVLV:
/* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */
av_push(PL_regex_padav, sv_dup_inc_NN(regexen[0],param));
for(i = 1; i <= len; i++) {
const SV * const regex = regexen[i];
+ /* FIXME for plugins
+ newSViv(PTR2IV(CALLREGDUPE(
+ INT2PTR(REGEXP *, SvIVX(regex)), param))))
+ */
+ /* And while we're at it, can we FIXME on the whole hiding
+ pointer inside an IV hack? */
SV * const sv =
SvREPADTMP(regex)
? sv_dup_inc(regex, param)
: SvREFCNT_inc(
- newSViv(PTR2IV(CALLREGDUPE(
- INT2PTR(REGEXP *, SvIVX(regex)), param))))
+ newSViv(PTR2IV(sv_dup_inc(INT2PTR(REGEXP *, SvIVX(regex)), param))))
;
if (SvFLAGS(regex) & SVf_BREAK)
SvFLAGS(sv) |= SVf_BREAK; /* unrefcnted PL_curpm */
_XPVMG_HEAD;
};
-struct xregexp {
- _XPV_HEAD;
- _XPVMG_HEAD;
- REGEXP * xrx_regexp; /* Our regular expression */
-};
-
struct xpvlv {
_XPV_HEAD;
_XPVMG_HEAD;
(tmpsv = (SV*)SvRV(sv)) && /* assign deliberate */
SvTYPE(tmpsv) == SVt_REGEXP)
{
- return ((struct xregexp *)SvANY(tmpsv))->xrx_regexp;
+ return tmpsv;
}
}
projects / p5sagit/p5-mst-13.2.git / commitdiff