#define RExC_seen (pRExC_state->seen)
#define RExC_size (pRExC_state->size)
#define RExC_npar (pRExC_state->npar)
-#define RExC_cpar (pRExC_state->cpar)
#define RExC_nestroot (pRExC_state->nestroot)
#define RExC_extralen (pRExC_state->extralen)
#define RExC_seen_zerolen (pRExC_state->seen_zerolen)
#define EXPERIMENTAL_INPLACESCAN
#endif
-#define DEBUG_STUDYDATA(data,depth) \
-DEBUG_OPTIMISE_MORE_r(if(data){ \
+#define DEBUG_STUDYDATA(str,data,depth) \
+DEBUG_OPTIMISE_MORE_r(if(data){ \
PerlIO_printf(Perl_debug_log, \
- "%*s"/* Len:%"IVdf"/%"IVdf" */"Pos:%"IVdf"/%"IVdf \
- " Flags: %"IVdf" Whilem_c: %"IVdf" Lcp: %"IVdf" ", \
+ "%*s" str "Pos:%"IVdf"/%"IVdf \
+ " Flags: 0x%"UVXf" Whilem_c: %"IVdf" Lcp: %"IVdf" %s", \
(int)(depth)*2, "", \
(IV)((data)->pos_min), \
(IV)((data)->pos_delta), \
- (IV)((data)->flags), \
+ (UV)((data)->flags), \
(IV)((data)->whilem_c), \
- (IV)((data)->last_closep ? *((data)->last_closep) : -1) \
+ (IV)((data)->last_closep ? *((data)->last_closep) : -1), \
+ is_inf ? "INF " : "" \
); \
if ((data)->last_found) \
PerlIO_printf(Perl_debug_log, \
floating substrings if needed. */
STATIC void
-S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *minlenp)
+S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *minlenp, int is_inf)
{
const STRLEN l = CHR_SVLEN(data->last_found);
const STRLEN old_l = CHR_SVLEN(*data->longest);
data->minlen_fixed=minlenp;
data->lookbehind_fixed=0;
}
- else {
+ else { /* *data->longest == data->longest_float */
data->offset_float_min = l ? data->last_start_min : data->pos_min;
data->offset_float_max = (l
? data->last_start_max
: data->pos_min + data->pos_delta);
- if ((U32)data->offset_float_max > (U32)I32_MAX)
+ if (is_inf || (U32)data->offset_float_max > (U32)I32_MAX)
data->offset_float_max = I32_MAX;
if (data->flags & SF_BEFORE_EOL)
data->flags
}
data->last_end = -1;
data->flags &= ~SF_BEFORE_EOL;
- DEBUG_STUDYDATA(data,0);
+ DEBUG_STUDYDATA("cl_anything: ",data,0);
}
/* Can match anything (initialization) */
#ifdef DEBUGGING
/*
- dump_trie(trie,widecharmap)
- dump_trie_interim_list(trie,widecharmap,next_alloc)
- dump_trie_interim_table(trie,widecharmap,next_alloc)
+ dump_trie(trie,widecharmap,revcharmap)
+ dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
+ dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
These routines dump out a trie in a somewhat readable format.
The _interim_ variants are used for debugging the interim
*/
STATIC void
-S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap, U32 depth)
+S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
+ AV *revcharmap, U32 depth)
{
U32 state;
SV *sv=sv_newmortal();
"Match","Base","Ofs" );
for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
- SV ** const tmp = av_fetch( trie->revcharmap, state, 0);
+ SV ** const tmp = av_fetch( revcharmap, state, 0);
if ( tmp ) {
PerlIO_printf( Perl_debug_log, "%*s",
colwidth,
*/
STATIC void
S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
- HV *widecharmap, U32 next_alloc, U32 depth)
+ HV *widecharmap, AV *revcharmap, U32 next_alloc,
+ U32 depth)
{
U32 state;
SV *sv=sv_newmortal();
);
}
for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
- SV ** const tmp = av_fetch( trie->revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0);
+ SV ** const tmp = av_fetch( revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0);
if ( tmp ) {
PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ",
colwidth,
*/
STATIC void
S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
- HV *widecharmap, U32 next_alloc, U32 depth)
+ HV *widecharmap, AV *revcharmap, U32 next_alloc,
+ U32 depth)
{
U32 state;
U16 charid;
PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" );
for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
- SV ** const tmp = av_fetch( trie->revcharmap, charid, 0);
+ SV ** const tmp = av_fetch( revcharmap, charid, 0);
if ( tmp ) {
PerlIO_printf( Perl_debug_log, "%*s",
colwidth,
SV *tmp = newSVpvs(""); \
if (UTF) SvUTF8_on(tmp); \
Perl_sv_catpvf( aTHX_ tmp, "%c", (int)uvc ); \
- av_push( TRIE_REVCHARMAP(trie), tmp ); \
+ av_push( revcharmap, tmp ); \
} STMT_END
#define TRIE_READ_CHAR STMT_START { \
else \
tmp = newSVpvn( "", 0 ); \
if ( UTF ) SvUTF8_on( tmp ); \
- av_push( trie->words, tmp ); \
+ av_push( trie_words, tmp ); \
}); \
\
curword++; \
/* first pass, loop through and scan words */
reg_trie_data *trie;
HV *widecharmap = NULL;
+ AV *revcharmap = newAV();
regnode *cur;
const U32 uniflags = UTF8_ALLOW_DEFAULT;
STRLEN len = 0;
)
);
- const U32 data_slot = add_data( pRExC_state, 2, "tu" );
- SV *re_trie_maxbuff;
-#ifndef DEBUGGING
- /* these are only used during construction but are useful during
- * debugging so we store them in the struct when debugging.
+#ifdef DEBUGGING
+ const U32 data_slot = add_data( pRExC_state, 4, "tuuu" );
+ AV *trie_words = NULL;
+ /* along with revcharmap, this only used during construction but both are
+ * useful during debugging so we store them in the struct when debugging.
*/
+#else
+ const U32 data_slot = add_data( pRExC_state, 2, "tu" );
STRLEN trie_charcount=0;
- AV *trie_revcharmap;
#endif
+ SV *re_trie_maxbuff;
GET_RE_DEBUG_FLAGS_DECL;
#ifndef DEBUGGING
PERL_UNUSED_ARG(depth);
if (!(UTF && folder))
trie->bitmap = PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
DEBUG_r({
- trie->words = newAV();
+ trie_words = newAV();
});
- TRIE_REVCHARMAP(trie) = newAV();
re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
if (!SvIOK(re_trie_maxbuff)) {
* sizeof(reg_trie_state) );
/* and now dump it out before we compress it */
- DEBUG_TRIE_COMPILE_MORE_r(
- dump_trie_interim_list(trie,widecharmap,next_alloc,depth+1)
+ DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
+ revcharmap, next_alloc,
+ depth+1)
);
trie->trans
} /* end second pass */
/* and now dump it out before we compress it */
- DEBUG_TRIE_COMPILE_MORE_r(
- dump_trie_interim_table(trie,widecharmap,next_alloc,depth+1)
- );
+ DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
+ revcharmap,
+ next_alloc, depth+1));
{
/*
* sizeof(reg_trie_trans) );
/* and now dump out the compressed format */
- DEBUG_TRIE_COMPILE_r(
- dump_trie(trie,widecharmap,depth+1)
- );
+ DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
{ /* Modify the program and insert the new TRIE node*/
U8 nodetype =(U8)(flags & 0xFF);
trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
{
if ( ++count > 1 ) {
- SV **tmp = av_fetch( TRIE_REVCHARMAP(trie), ofs, 0);
+ SV **tmp = av_fetch( revcharmap, ofs, 0);
const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
if ( state == 1 ) break;
if ( count == 2 ) {
(int)depth * 2 + 2, "",
(UV)state));
if (idx >= 0) {
- SV ** const tmp = av_fetch( TRIE_REVCHARMAP(trie), idx, 0);
+ SV ** const tmp = av_fetch( revcharmap, idx, 0);
const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
TRIE_BITMAP_SET(trie,*ch);
}
}
if ( count == 1 ) {
- SV **tmp = av_fetch( TRIE_REVCHARMAP(trie), idx, 0);
+ SV **tmp = av_fetch( revcharmap, idx, 0);
char *ch = SvPV_nolen( *tmp );
DEBUG_OPTIMISE_r({
SV *sv=sv_newmortal();
Set_Node_Offset_Length(fix, 0, 0);
}
while (word--) {
- SV ** const tmp = av_fetch( trie->words, word, 0 );
+ SV ** const tmp = av_fetch( trie_words, word, 0 );
if (tmp) {
if ( STR_LEN(convert) <= SvCUR(*tmp) )
sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
});
} /* end node insert */
RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
-#ifndef DEBUGGING
- SvREFCNT_dec(TRIE_REVCHARMAP(trie));
+#ifdef DEBUGGING
+ RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
+ RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
+#else
+ SvREFCNT_dec(revcharmap);
#endif
return trie->jump
? MADE_JUMP_TRIE
I32 stop; /* what stopparen do we use */
} scan_frame;
+
+#define SCAN_COMMIT(s, data, m) scan_commit(s, data, m, is_inf)
+
STATIC I32
S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
I32 *minlenp, I32 *deltap,
fake_study_recurse:
while ( scan && OP(scan) != END && scan < last ){
/* Peephole optimizer: */
- DEBUG_STUDYDATA(data,depth);
+ DEBUG_STUDYDATA("Peep:", data,depth);
DEBUG_PEEP("Peep",scan,depth);
JOIN_EXACT(scan,&min,0);
regnode * const startbranch=scan;
if (flags & SCF_DO_SUBSTR)
- scan_commit(pRExC_state, data, minlenp); /* Cannot merge strings after this. */
+ SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot merge strings after this. */
if (flags & SCF_DO_STCLASS)
cl_init_zero(pRExC_state, &accum);
Newx(newframe,1,scan_frame);
} else {
if (flags & SCF_DO_SUBSTR) {
- scan_commit(pRExC_state,data,minlenp);
+ SCAN_COMMIT(pRExC_state,data,minlenp);
data->longest = &(data->longest_float);
}
is_inf = is_inf_internal = 1;
/* Search for fixed substrings supports EXACT only. */
if (flags & SCF_DO_SUBSTR) {
assert(data);
- scan_commit(pRExC_state, data, minlenp);
+ SCAN_COMMIT(pRExC_state, data, minlenp);
}
if (UTF) {
const U8 * const s = (U8 *)STRING(scan);
is_inf = is_inf_internal = 1;
scan = regnext(scan);
if (flags & SCF_DO_SUBSTR) {
- scan_commit(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */
+ SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */
data->longest = &(data->longest_float);
}
goto optimize_curly_tail;
next_is_eval = (OP(scan) == EVAL);
do_curly:
if (flags & SCF_DO_SUBSTR) {
- if (mincount == 0) scan_commit(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */
+ if (mincount == 0) SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */
pos_before = data->pos_min;
}
if (data) {
if (mincount != maxcount) {
/* Cannot extend fixed substrings found inside
the group. */
- scan_commit(pRExC_state,data,minlenp);
+ SCAN_COMMIT(pRExC_state,data,minlenp);
if (mincount && last_str) {
SV * const sv = data->last_found;
MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
continue;
default: /* REF and CLUMP only? */
if (flags & SCF_DO_SUBSTR) {
- scan_commit(pRExC_state,data,minlenp); /* Cannot expect anything... */
+ SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */
data->longest = &(data->longest_float);
}
is_inf = is_inf_internal = 1;
int value = 0;
if (flags & SCF_DO_SUBSTR) {
- scan_commit(pRExC_state,data,minlenp);
+ SCAN_COMMIT(pRExC_state,data,minlenp);
data->pos_min++;
}
min++;
if ((flags & SCF_DO_SUBSTR) && data->last_found) {
f |= SCF_DO_SUBSTR;
if (scan->flags)
- scan_commit(pRExC_state, &data_fake,minlenp);
+ SCAN_COMMIT(pRExC_state, &data_fake,minlenp);
data_fake.last_found=newSVsv(data->last_found);
}
}
if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
if (RExC_rx->minlen<*minnextp)
RExC_rx->minlen=*minnextp;
- scan_commit(pRExC_state, &data_fake, minnextp);
+ SCAN_COMMIT(pRExC_state, &data_fake, minnextp);
SvREFCNT_dec(data_fake.last_found);
if ( data_fake.minlen_fixed != minlenp )
}
else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
if (flags & SCF_DO_SUBSTR) {
- scan_commit(pRExC_state,data,minlenp);
+ SCAN_COMMIT(pRExC_state,data,minlenp);
flags &= ~SCF_DO_SUBSTR;
}
if (data && OP(scan)==ACCEPT) {
else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
{
if (flags & SCF_DO_SUBSTR) {
- scan_commit(pRExC_state,data,minlenp);
+ SCAN_COMMIT(pRExC_state,data,minlenp);
data->longest = &(data->longest_float);
}
is_inf = is_inf_internal = 1;
struct regnode_charclass_class accum;
if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
- scan_commit(pRExC_state, data,minlenp); /* Cannot merge strings after this. */
+ SCAN_COMMIT(pRExC_state, data,minlenp); /* Cannot merge strings after this. */
if (flags & SCF_DO_STCLASS)
cl_init_zero(pRExC_state, &accum);
delta += (trie->maxlen - trie->minlen);
flags &= ~SCF_DO_STCLASS; /* xxx */
if (flags & SCF_DO_SUBSTR) {
- scan_commit(pRExC_state,data,minlenp); /* Cannot expect anything... */
+ SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */
data->pos_min += trie->minlen;
data->pos_delta += (trie->maxlen - trie->minlen);
if (trie->maxlen != trie->minlen)
finish:
assert(!frame);
+ DEBUG_STUDYDATA("pre-fin:",data,depth);
*scanp = scan;
*deltap = is_inf_internal ? I32_MAX : delta;
if (flags & SCF_TRIE_RESTUDY)
data->flags |= SCF_TRIE_RESTUDY;
- DEBUG_STUDYDATA(data,depth);
+ DEBUG_STUDYDATA("post-fin:",data,depth);
return min < stopmin ? min : stopmin;
}
return count;
}
+/*XXX: todo make this not included in a non debugging perl */
#ifndef PERL_IN_XSUB_RE
void
Perl_reginitcolors(pTHX)
extern const struct regexp_engine my_reg_engine;
#define RE_ENGINE_PTR &my_reg_engine
#endif
-/* these make a few things look better, to avoid indentation */
-#define BEGIN_BLOCK {
-#define END_BLOCK }
-
+
+#ifndef PERL_IN_XSUB_RE
regexp *
Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
{
dVAR;
- GET_RE_DEBUG_FLAGS_DECL;
- DEBUG_r(if (!PL_colorset) reginitcolors());
-#ifndef PERL_IN_XSUB_RE
- BEGIN_BLOCK
+ HV * const table = GvHV(PL_hintgv);
/* Dispatch a request to compile a regexp to correct
regexp engine. */
- HV * const table = GvHV(PL_hintgv);
if (table) {
SV **ptr= hv_fetchs(table, "regcomp", FALSE);
+ GET_RE_DEBUG_FLAGS_DECL;
if (ptr && SvIOK(*ptr) && SvIV(*ptr)) {
const regexp_engine *eng=INT2PTR(regexp_engine*,SvIV(*ptr));
DEBUG_COMPILE_r({
return CALLREGCOMP_ENG(eng, exp, xend, pm);
}
}
- END_BLOCK
+ return Perl_re_compile(aTHX_ exp, xend, pm);
+}
#endif
- BEGIN_BLOCK
+
+regexp *
+Perl_re_compile(pTHX_ char *exp, char *xend, PMOP *pm)
+{
+ dVAR;
register regexp *r;
register regexp_internal *ri;
regnode *scan;
int restudied= 0;
RExC_state_t copyRExC_state;
#endif
+ GET_RE_DEBUG_FLAGS_DECL;
+ DEBUG_r(if (!PL_colorset) reginitcolors());
+
if (exp == NULL)
FAIL("NULL regexp argument");
RExC_end = xend;
RExC_naughty = 0;
RExC_npar = 1;
- RExC_cpar = 1;
RExC_nestroot = 0;
RExC_size = 0L;
RExC_emit = &PL_regdummy;
RExC_end = xend;
RExC_naughty = 0;
RExC_npar = 1;
- RExC_cpar = 1;
RExC_emit_start = ri->program;
RExC_emit = ri->program;
#ifdef DEBUGGING
ri->program[RExC_size].type = 255;
#endif
/* Store the count of eval-groups for security checks: */
- RExC_emit->next_off = (RExC_seen_evals > (I32)U16_MAX) ? U16_MAX : (U16)RExC_seen_evals;
+ RExC_rx->seen_evals = RExC_seen_evals;
REGC((U8)REG_MAGIC, (char*) RExC_emit++);
if (reg(pRExC_state, 0, &flags,1) == NULL)
return(NULL);
if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
&& data.last_start_min == 0 && data.last_end > 0
&& !RExC_seen_zerolen
+ && !(RExC_seen & REG_SEEN_VERBARG)
&& (!(RExC_seen & REG_SEEN_GPOS) || (r->extflags & RXf_ANCH_GPOS)))
r->extflags |= RXf_CHECK_ALL;
- scan_commit(pRExC_state, &data,&minlen);
+ scan_commit(pRExC_state, &data,&minlen,0);
SvREFCNT_dec(data.last_found);
/* Note that code very similar to this but for anchored string
PerlIO_printf(Perl_debug_log, "\n");
});
return(r);
- END_BLOCK
}
#undef CORE_ONLY_BLOCK
-#undef END_BLOCK
#undef RE_ENGINE_PTR
#ifndef PERL_IN_XSUB_RE
ender = reg_node(pRExC_state, TAIL);
break;
case 1:
- RExC_cpar++;
ender = reganode(pRExC_state, CLOSE, parno);
if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
case 'c':
case '0':
goto defchar;
- case 'R':
+ case 'g':
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
{
I32 num;
- bool isrel=(*RExC_parse=='R');
- if (isrel)
+ bool isg = *RExC_parse == 'g';
+ bool isrel = 0;
+ bool hasbrace = 0;
+ if (isg) {
RExC_parse++;
+ if (*RExC_parse == '{') {
+ RExC_parse++;
+ hasbrace = 1;
+ }
+ if (*RExC_parse == '-') {
+ RExC_parse++;
+ isrel = 1;
+ }
+ }
num = atoi(RExC_parse);
if (isrel) {
- num = RExC_cpar - num;
+ num = RExC_npar - num;
if (num < 1)
vFAIL("Reference to nonexistent or unclosed group");
}
- if (num > 9 && num >= RExC_npar)
+ if (!isg && num > 9 && num >= RExC_npar)
goto defchar;
else {
char * const parse_start = RExC_parse - 1; /* MJD */
while (isDIGIT(*RExC_parse))
RExC_parse++;
-
+ if (hasbrace) {
+ if (*RExC_parse != '}')
+ vFAIL("Unterminated \\g{...} pattern");
+ RExC_parse++;
+ }
if (!SIZE_ONLY) {
if (num > (I32)RExC_rx->nparens)
vFAIL("Reference to nonexistent group");
- /* People make this error all the time apparently.
- So we cant fail on it, even though we should
-
- else if (num >= RExC_cpar)
- vFAIL("Reference to unclosed group will always match");
- */
}
RExC_sawback = 1;
ret = reganode(pRExC_state,
case 'C':
case 'X':
case 'G':
+ case 'g':
case 'Z':
case 'z':
case 'w':
case 'P':
case 'N':
case 'R':
+ case 'k':
--p;
goto loopdone;
case 'n':
}
/*
- pregfree - free a regexp
+ pregfree()
+
+ handles refcounting and freeing the perl core regexp structure. When
+ it is necessary to actually free the structure the first thing it
+ does is call the 'free' method of the regexp_engine associated to to
+ the regexp, allowing the handling of the void *pprivate; member
+ first. (This routine is not overridable by extensions, which is why
+ the extensions free is called first.)
- See regdupe below if you change anything here.
+ See regdupe and regdupe_internal if you change anything here.
*/
-
+#ifndef PERL_IN_XSUB_RE
void
Perl_pregfree(pTHX_ struct regexp *r)
{
dVAR;
- RXi_GET_DECL(r,ri);
GET_RE_DEBUG_FLAGS_DECL;
if (!r || (--r->refcnt > 0))
return;
- DEBUG_COMPILE_r({
- if (!PL_colorset)
- reginitcolors();
- {
- SV *dsv= sv_newmortal();
- RE_PV_QUOTED_DECL(s, (r->extflags & RXf_UTF8),
- dsv, r->precomp, r->prelen, 60);
- PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n",
- PL_colors[4],PL_colors[5],s);
- }
- });
-
+
+ CALLREGFREE_PVT(r); /* free the private data */
+
/* gcov results gave these as non-null 100% of the time, so there's no
optimisation in checking them before calling Safefree */
Safefree(r->precomp);
- Safefree(ri->offsets); /* 20010421 MJD */
RX_MATCH_COPY_FREE(r);
#ifdef PERL_OLD_COPY_ON_WRITE
if (r->saved_copy)
}
if (r->paren_names)
SvREFCNT_dec(r->paren_names);
+
+ Safefree(r->startp);
+ Safefree(r->endp);
+ Safefree(r);
+}
+#endif
+
+/* regfree_internal()
+
+ Free the private data in a regexp. This is overloadable by
+ extensions. Perl takes care of the regexp structure in pregfree(),
+ this covers the *pprivate pointer which technically perldoesnt
+ know about, however of course we have to handle the
+ regexp_internal structure when no extension is in use.
+
+ Note this is called before freeing anything in the regexp
+ structure.
+ */
+
+void
+Perl_regfree_internal(pTHX_ struct regexp *r)
+{
+ dVAR;
+ RXi_GET_DECL(r,ri);
+ GET_RE_DEBUG_FLAGS_DECL;
+
+ DEBUG_COMPILE_r({
+ if (!PL_colorset)
+ reginitcolors();
+ {
+ SV *dsv= sv_newmortal();
+ RE_PV_QUOTED_DECL(s, (r->extflags & RXf_UTF8),
+ dsv, r->precomp, r->prelen, 60);
+ PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n",
+ PL_colors[4],PL_colors[5],s);
+ }
+ });
+
+ Safefree(ri->offsets); /* 20010421 MJD */
if (ri->data) {
int n = ri->data->count;
PAD* new_comppad = NULL;
PerlMemShared_free(trie->jump);
if (trie->nextword)
PerlMemShared_free(trie->nextword);
-#ifdef DEBUGGING
- if (trie->words)
- SvREFCNT_dec((SV*)trie->words);
- if (trie->revcharmap)
- SvREFCNT_dec((SV*)trie->revcharmap);
-#endif
/* do this last!!!! */
PerlMemShared_free(ri->data->data[n]);
}
Safefree(ri->data->what);
Safefree(ri->data);
}
- Safefree(r->startp);
- Safefree(r->endp);
if (ri->swap) {
Safefree(ri->swap->startp);
Safefree(ri->swap->endp);
Safefree(ri->swap);
}
Safefree(ri);
- Safefree(r);
}
#define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
given regexp structure. It is a no-op when not under USE_ITHREADS.
(Originally this *was* re_dup() for change history see sv.c)
- See pregfree() above if you change anything here.
+ After all of the core data stored in struct regexp is duplicated
+ the regexp_engine.dupe method is used to copy any private data
+ stored in the *pprivate pointer. This allows extensions to handle
+ any duplication it needs to do.
+
+ See pregfree() and regfree_internal() if you change anything here.
*/
#if defined(USE_ITHREADS)
+#ifndef PERL_IN_XSUB_RE
regexp *
-Perl_regdupe(pTHX_ const regexp *r, CLONE_PARAMS *param)
+Perl_re_dup(pTHX_ const regexp *r, CLONE_PARAMS *param)
{
dVAR;
regexp *ret;
- regexp_internal *reti;
- int i, len, npar;
+ int i, npar;
struct reg_substr_datum *s;
- RXi_GET_DECL(r,ri);
-
+
if (!r)
return (REGEXP *)NULL;
if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
return ret;
- len = ri->offsets[0];
+
npar = r->nparens+1;
-
Newxz(ret, 1, regexp);
- Newxc(reti, sizeof(regexp_internal) + (len+1)*sizeof(regnode), char, regexp_internal);
- RXi_SET(ret,reti);
- Copy(ri->program, reti->program, len+1, regnode);
-
Newx(ret->startp, npar, I32);
Copy(r->startp, ret->startp, npar, I32);
Newx(ret->endp, npar, I32);
- Copy(r->startp, ret->startp, npar, I32);
+ Copy(r->endp, ret->endp, npar, I32);
+
+ if (ret->substrs) {
+ Newx(ret->substrs, 1, struct reg_substr_data);
+ for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
+ s->min_offset = r->substrs->data[i].min_offset;
+ s->max_offset = r->substrs->data[i].max_offset;
+ s->end_shift = r->substrs->data[i].end_shift;
+ s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
+ s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
+ }
+ } else
+ ret->substrs = NULL;
+
+ ret->precomp = SAVEPVN(r->precomp, r->prelen);
+ ret->refcnt = r->refcnt;
+ ret->minlen = r->minlen;
+ ret->minlenret = r->minlenret;
+ ret->prelen = r->prelen;
+ ret->nparens = r->nparens;
+ ret->lastparen = r->lastparen;
+ ret->lastcloseparen = r->lastcloseparen;
+ ret->intflags = r->intflags;
+ ret->extflags = r->extflags;
+
+ ret->sublen = r->sublen;
+
+ ret->engine = r->engine;
+
+ ret->paren_names = hv_dup_inc(r->paren_names, param);
+
+ if (RX_MATCH_COPIED(ret))
+ ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
+ else
+ ret->subbeg = NULL;
+#ifdef PERL_OLD_COPY_ON_WRITE
+ ret->saved_copy = NULL;
+#endif
+
+ ret->pprivate = r->pprivate;
+ if (ret->pprivate)
+ RXi_SET(ret,CALLREGDUPE_PVT(ret,param));
+
+ ptr_table_store(PL_ptr_table, r, ret);
+ return ret;
+}
+#endif /* PERL_IN_XSUB_RE */
+
+/*
+ regdupe_internal()
+
+ This is the internal complement to regdupe() which is used to copy
+ the structure pointed to by the *pprivate pointer in the regexp.
+ This is the core version of the extension overridable cloning hook.
+ The regexp structure being duplicated will be copied by perl prior
+ to this and will be provided as the regexp *r argument, however
+ with the /old/ structures pprivate pointer value. Thus this routine
+ may override any copying normally done by perl.
+
+ It returns a pointer to the new regexp_internal structure.
+*/
+
+void *
+Perl_regdupe_internal(pTHX_ const regexp *r, CLONE_PARAMS *param)
+{
+ dVAR;
+ regexp_internal *reti;
+ int len, npar;
+ RXi_GET_DECL(r,ri);
+
+ npar = r->nparens+1;
+ len = ri->offsets[0];
+
+ Newxc(reti, sizeof(regexp_internal) + (len+1)*sizeof(regnode), char, regexp_internal);
+ Copy(ri->program, reti->program, len+1, regnode);
+
if(ri->swap) {
Newx(reti->swap, 1, regexp_paren_ofs);
/* no need to copy these */
reti->swap = NULL;
}
- Newx(ret->substrs, 1, struct reg_substr_data);
- for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
- s->min_offset = r->substrs->data[i].min_offset;
- s->max_offset = r->substrs->data[i].max_offset;
- s->end_shift = r->substrs->data[i].end_shift;
- s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
- s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
- }
reti->regstclass = NULL;
if (ri->data) {
Newx(reti->offsets, 2*len+1, U32);
Copy(ri->offsets, reti->offsets, 2*len+1, U32);
-
- ret->precomp = SAVEPVN(r->precomp, r->prelen);
- ret->refcnt = r->refcnt;
- ret->minlen = r->minlen;
- ret->minlenret = r->minlenret;
- ret->prelen = r->prelen;
- ret->nparens = r->nparens;
- ret->lastparen = r->lastparen;
- ret->lastcloseparen = r->lastcloseparen;
- ret->intflags = r->intflags;
- ret->extflags = r->extflags;
-
- ret->sublen = r->sublen;
-
- ret->engine = r->engine;
- ret->paren_names = hv_dup_inc(r->paren_names, param);
-
- if (RX_MATCH_COPIED(ret))
- ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
- else
- ret->subbeg = NULL;
-#ifdef PERL_OLD_COPY_ON_WRITE
- ret->saved_copy = NULL;
-#endif
-
- ptr_table_store(PL_ptr_table, r, ret);
- return ret;
+ return (void*)reti;
}
-#endif
+
+#endif /* USE_ITHREADS */
/*
reg_stringify()
resulting string
If flags is nonnull and the returned string contains UTF8 then
- (flags & 1) will be true.
+ (*flags & 1) will be true.
If haseval is nonnull then it is used to return whether the pattern
contains evals.
Normally called via macro:
- CALLREG_STRINGIFY(mg,0,0);
+ CALLREG_STRINGIFY(mg,&len,&utf8);
And internally with
- CALLREG_AS_STR(mg,lp,flags,haseval)
+ CALLREG_AS_STR(mg,&lp,&flags,&haseval)
See sv_2pv_flags() in sv.c for an example of internal usage.
*/
-
+#ifndef PERL_IN_XSUB_RE
char *
Perl_reg_stringify(pTHX_ MAGIC *mg, STRLEN *lp, U32 *flags, I32 *haseval ) {
dVAR;
const regexp * const re = (regexp *)mg->mg_obj;
- RXi_GET_DECL(re,ri);
-
+
if (!mg->mg_ptr) {
const char *fptr = "msix";
char reflags[6];
mg->mg_ptr[mg->mg_len] = 0;
}
if (haseval)
- *haseval = ri->program[0].next_off;
+ *haseval = re->seen_evals;
if (flags)
*flags = ((re->extflags & RXf_UTF8) ? 1 : 0);
return mg->mg_ptr;
}
-
-#ifndef PERL_IN_XSUB_RE
/*
- regnext - dig the "next" pointer out of a node
*/
NULL;
const reg_trie_data * const trie =
(reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
+#ifdef DEBUGGING
+ AV *const trie_words = (AV *) ri->data->data[n + TRIE_WORDS_OFFSET];
+#endif
const regnode *nextbranch= NULL;
I32 word_idx;
sv_setpvn(sv, "", 0);
for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
- SV ** const elem_ptr = av_fetch(trie->words,word_idx,0);
+ SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
PerlIO_printf(Perl_debug_log, "%*s%s ",
(int)(2*(indent+3)), "",
projects / p5sagit/p5-mst-13.2.git / blobdiff