#define RExC_starttry (pRExC_state->starttry)
#endif
#ifdef DEBUGGING
- char *lastparse;
+ const char *lastparse;
I32 lastnum;
#define RExC_lastparse (pRExC_state->lastparse)
#define RExC_lastnum (pRExC_state->lastnum)
#define TRIE_STORE_REVCHAR \
STMT_START { \
SV *tmp = Perl_newSVpvf_nocontext( "%c", (int)uvc ); \
+ if (UTF) SvUTF8_on(tmp); \
av_push( TRIE_REVCHARMAP(trie), tmp ); \
} STMT_END
S_dump_trie(pTHX_ const struct _reg_trie_data *trie,U32 depth)
{
U32 state;
+ SV *sv=sv_newmortal();
+ int colwidth= trie->widecharmap ? 6 : 4;
GET_RE_DEBUG_FLAGS_DECL;
+
PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
(int)depth * 2 + 2,"",
"Match","Base","Ofs" );
for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
- SV **tmp = av_fetch( trie->revcharmap, state, 0);
+ SV ** const tmp = av_fetch( trie->revcharmap, state, 0);
if ( tmp ) {
- PerlIO_printf( Perl_debug_log, "%4.4s ", SvPV_nolen_const( *tmp ) );
+ PerlIO_printf( Perl_debug_log, "%*s",
+ colwidth,
+ pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
+ PL_colors[0], PL_colors[1],
+ (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
+ PERL_PV_ESCAPE_FIRSTCHAR
+ )
+ );
}
}
PerlIO_printf( Perl_debug_log, "\n%*sState|-----------------------",
(int)depth * 2 + 2,"");
for( state = 0 ; state < trie->uniquecharcount ; state++ )
- PerlIO_printf( Perl_debug_log, "-----");
+ PerlIO_printf( Perl_debug_log, "%.*s", colwidth, "--------");
PerlIO_printf( Perl_debug_log, "\n");
for( state = 1 ; state < TRIE_LASTSTATE(trie) ; state++ ) {
- const U32 base = trie->states[ state ].trans.base;
+ const U32 base = trie->states[ state ].trans.base;
PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|", (int)depth * 2 + 2,"", (UV)state);
( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
{
- PerlIO_printf( Perl_debug_log, "%4"UVXf" ",
+ PerlIO_printf( Perl_debug_log, "%*"UVXf,
+ colwidth,
(UV)trie->trans[ base + ofs - trie->uniquecharcount ].next );
} else {
- PerlIO_printf( Perl_debug_log, "%4s "," ." );
+ PerlIO_printf( Perl_debug_log, "%*s",colwidth," ." );
}
}
S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie, U32 next_alloc,U32 depth)
{
U32 state;
+ SV *sv=sv_newmortal();
+ int colwidth= trie->widecharmap ? 6 : 4;
GET_RE_DEBUG_FLAGS_DECL;
/* print out the table precompression. */
- PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s",
- (int)depth * 2 + 2,"", (int)depth * 2 + 2,"");
- PerlIO_printf( Perl_debug_log, "------:-----+-----------------" );
+ PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s",
+ (int)depth * 2 + 2,"", (int)depth * 2 + 2,"",
+ "------:-----+-----------------\n" );
for( state=1 ; state < next_alloc ; state ++ ) {
U16 charid;
- PerlIO_printf( Perl_debug_log, "\n%*s %4"UVXf" :",
+ PerlIO_printf( Perl_debug_log, "%*s %4"UVXf" :",
(int)depth * 2 + 2,"", (UV)state );
if ( ! trie->states[ state ].wordnum ) {
PerlIO_printf( Perl_debug_log, "%5s| ","");
);
}
for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
- SV **tmp = av_fetch( trie->revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0);
- PerlIO_printf( Perl_debug_log, "%s:%3X=%4"UVXf" | ",
- SvPV_nolen_const( *tmp ),
+ SV ** const tmp = av_fetch( trie->revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0);
+ if ( tmp ) {
+ PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ",
+ colwidth,
+ pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
+ PL_colors[0], PL_colors[1],
+ (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
+ PERL_PV_ESCAPE_FIRSTCHAR
+ ) ,
TRIE_LIST_ITEM(state,charid).forid,
(UV)TRIE_LIST_ITEM(state,charid).newstate
);
}
-
+ }
+ PerlIO_printf( Perl_debug_log, "\n");
}
}
{
U32 state;
U16 charid;
+ SV *sv=sv_newmortal();
+ int colwidth= trie->widecharmap ? 6 : 4;
GET_RE_DEBUG_FLAGS_DECL;
/*
PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" );
for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
- SV **tmp = av_fetch( trie->revcharmap, charid, 0);
+ SV ** const tmp = av_fetch( trie->revcharmap, charid, 0);
if ( tmp ) {
- PerlIO_printf( Perl_debug_log, "%4.4s ", SvPV_nolen_const( *tmp ) );
+ PerlIO_printf( Perl_debug_log, "%*s",
+ colwidth,
+ pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
+ PL_colors[0], PL_colors[1],
+ (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
+ PERL_PV_ESCAPE_FIRSTCHAR
+ )
+ );
}
}
PerlIO_printf( Perl_debug_log, "\n%*sState+-",(int)depth * 2 + 2,"" );
for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
- PerlIO_printf( Perl_debug_log, "%4s-", "----" );
+ PerlIO_printf( Perl_debug_log, "%.*s", colwidth,"--------");
}
PerlIO_printf( Perl_debug_log, "\n" );
(UV)TRIE_NODENUM( state ) );
for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
- PerlIO_printf( Perl_debug_log, "%4"UVXf" ",
- (UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next ) );
+ UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
+ if (v)
+ PerlIO_printf( Perl_debug_log, "%*"UVXf, colwidth, v );
+ else
+ PerlIO_printf( Perl_debug_log, "%*s", colwidth, "." );
}
if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n", (UV)trie->trans[ state ].check );
/* add a fail transition */
reg_trie_data *trie=(reg_trie_data *)RExC_rx->data->data[ARG(source)];
U32 *q;
- U32 ucharcount = trie->uniquecharcount;
- U32 numstates = trie->laststate;
- U32 ubound = trie->lasttrans + ucharcount;
+ const U32 ucharcount = trie->uniquecharcount;
+ const U32 numstates = trie->laststate;
+ const U32 ubound = trie->lasttrans + ucharcount;
U32 q_read = 0;
U32 q_write = 0;
U32 charid;
U32 base = trie->states[ 1 ].trans.base;
- U32 newstate;
U32 *fail;
reg_ac_data *aho;
const U32 data_slot = add_data( pRExC_state, 1, "T" );
GET_RE_DEBUG_FLAGS_DECL;
+#ifndef DEBUGGING
+ PERL_UNUSED_ARG(depth);
+#endif
+
ARG_SET( stclass, data_slot );
Newxz( aho, 1, reg_ac_data );
(trie->laststate+1)*sizeof(reg_trie_state));
Newxz( q, numstates, U32);
Newxz( aho->fail, numstates, U32 );
- fail= aho->fail;
+ aho->refcount = 1;
+ fail = aho->fail;
fail[ 0 ] = fail[ 1 ] = 1;
for ( charid = 0; charid < ucharcount ; charid++ ) {
- newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
- if ( newstate )
- {
+ const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
+ if ( newstate ) {
q[ q_write ] = newstate;
/* set to point at the root */
fail[ q[ q_write++ ] ]=1;
}
}
while ( q_read < q_write) {
- U32 cur = q[ q_read++ % numstates ];
- U32 ch_state;
+ const U32 cur = q[ q_read++ % numstates ];
base = trie->states[ cur ].trans.base;
for ( charid = 0 ; charid < ucharcount ; charid++ ) {
- if ( ( ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 ) ) ) {
+ const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
+ if (ch_state) {
U32 fail_state = cur;
U32 fail_base;
do {
AV *trie_revcharmap;
#endif
GET_RE_DEBUG_FLAGS_DECL;
+#ifndef DEBUGGING
+ PERL_UNUSED_ARG(depth);
+#endif
Newxz( trie, 1, reg_trie_data );
trie->refcount = 1;
PerlIO_printf( Perl_debug_log, "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
(int)depth * 2 + 2,"",
( trie->widecharmap ? "UTF8" : "NATIVE" ), TRIE_WORDCOUNT(trie),
- (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount, trie->minlen, trie->maxlen )
+ (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
+ (int)trie->minlen, (int)trie->maxlen )
);
Newxz( trie->wordlen, TRIE_WORDCOUNT(trie), U32 );
"%*sNew Start State=%"UVuf" Class: [",
(int)depth * 2 + 2, "",
state));
- if (idx>-1) {
- SV **tmp = av_fetch( TRIE_REVCHARMAP(trie), idx, 0);
- const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
+ if (idx >= 0) {
+ SV ** const tmp = av_fetch( TRIE_REVCHARMAP(trie), idx, 0);
+ const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
TRIE_BITMAP_SET(trie,*ch);
if ( folder )
STR_LEN(convert)++;
} else {
+#ifdef DEBUGGING
if (state>1)
DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n"));
+#endif
break;
}
}
if (PL_regkind[OP(scan)] == EXACT) \
join_exact(pRExC_state,(scan),(min),(flags),NULL,depth+1)
-U32
+STATIC U32
S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, I32 *min, U32 flags,regnode *val, U32 depth) {
/* Merge several consecutive EXACTish nodes into one. */
regnode *n = regnext(scan);
U32 stopnow = 0;
#ifdef DEBUGGING
regnode *stop = scan;
-#endif
GET_RE_DEBUG_FLAGS_DECL;
+#else
+ PERL_UNUSED_ARG(depth);
+#endif
+#ifndef EXPERIMENTAL_INPLACESCAN
+ PERL_UNUSED_ARG(flags);
+ PERL_UNUSED_ARG(val);
+#endif
DEBUG_PEEP("join",scan,depth);
/* Skip NOTHING, merge EXACT*. */
if (OP(n) == TAIL || n > next)
stringok = 0;
if (PL_regkind[OP(n)] == NOTHING) {
-
DEBUG_PEEP("skip:",n,depth);
NEXT_OFF(scan) += NEXT_OFF(n);
next = n + NODE_STEP_REGNODE;
if (stopnow) break;
}
-#ifdef EXPERIMENTAL_INPLACESCAN
- if (flags && !NEXT_OFF(n)) {
- DEBUG_PEEP("atch",val,depth);
- if (reg_off_by_arg[OP(n)]) {
- ARG_SET(n, val - n);
- }
- else {
- NEXT_OFF(n) = val - n;
- }
- stopnow=1;
- }
+#ifdef EXPERIMENTAL_INPLACESCAN
+ if (flags && !NEXT_OFF(n)) {
+ DEBUG_PEEP("atch", val, depth);
+ if (reg_off_by_arg[OP(n)]) {
+ ARG_SET(n, val - n);
+ }
+ else {
+ NEXT_OFF(n) = val - n;
+ }
+ stopnow = 1;
+ }
#endif
}
char * const s0 = STRING(scan), *s, *t;
char * const s1 = s0 + STR_LEN(scan) - 1;
char * const s2 = s1 - 4;
+#ifdef EBCDIC /* RD tunifold greek 0390 and 03B0 */
+ const char t0[] = "\xaf\x49\xaf\x42";
+#else
const char t0[] = "\xcc\x88\xcc\x81";
+#endif
const char * const t1 = t0 + 3;
for (s = s0 + 2;
s < s2 && (t = ninstr(s, s1, t0, t1));
s = t + 4) {
+#ifdef EBCDIC
+ if (((U8)t[-1] == 0x68 && (U8)t[-2] == 0xB4) ||
+ ((U8)t[-1] == 0x46 && (U8)t[-2] == 0xB5))
+#else
if (((U8)t[-1] == 0xB9 && (U8)t[-2] == 0xCE) ||
((U8)t[-1] == 0x85 && (U8)t[-2] == 0xCF))
+#endif
*min -= 4;
}
}
SV *re_trie_maxbuff = NULL;
GET_RE_DEBUG_FLAGS_DECL;
+#ifdef DEBUGGING
+ StructCopy(&zero_scan_data, &data_fake, scan_data_t);
+#endif
while (scan && OP(scan) != END && scan < last) {
/* Peephole optimizer: */
}
scan->flags = (U8)minnext;
}
- if (data && data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
- pars++;
- if (data && (data_fake.flags & SF_HAS_EVAL))
- data->flags |= SF_HAS_EVAL;
- if (data)
+ if (data) {
+ if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
+ pars++;
+ if (data_fake.flags & SF_HAS_EVAL)
+ data->flags |= SF_HAS_EVAL;
data->whilem_c = data_fake.whilem_c;
+ }
if (f & SCF_DO_STCLASS_AND) {
const int was = (data->start_class->flags & ANYOF_EOS);
I32 sawopen = 0;
scan_data_t data;
RExC_state_t RExC_state;
- RExC_state_t *pRExC_state = &RExC_state;
+ RExC_state_t * const pRExC_state = &RExC_state;
#ifdef TRIE_STUDY_OPT
int restudied= 0;
RExC_state_t copyRExC_state;
RExC_precomp = exp;
DEBUG_r(if (!PL_colorset) reginitcolors());
DEBUG_COMPILE_r({
- PerlIO_printf(Perl_debug_log, "%sCompiling REx%s \"%s%*s%s\"\n",
- PL_colors[4],PL_colors[5],PL_colors[0],
- (int)(xend - exp), RExC_precomp, PL_colors[1]);
+ SV *dsv= sv_newmortal();
+ RE_PV_QUOTED_DECL(s, RExC_utf8,
+ dsv, RExC_precomp, (xend - exp), 60);
+ PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
+ PL_colors[4],PL_colors[5],s);
});
RExC_flags = pm->op_pmflags;
RExC_sawback = 0;
if (OP(first) == IFMATCH) {
first = NEXTOPER(first);
first += EXTRA_STEP_2ARGS;
- } else /*xxx possible optimisation for /(?=)/*/
+ } else /* XXX possible optimisation for /(?=)/ */
first = NEXTOPER(first);
}
r->reganch |= ROPT_SKIP;
/* Scan is after the zeroth branch, first is atomic matcher. */
- DEBUG_COMPILE_r(PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
- (IV)(first - scan + 1)));
+#ifdef TRIE_STUDY_OPT
+ DEBUG_COMPILE_r(
+ if (!restudied)
+ PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
+ (IV)(first - scan + 1))
+ );
+#else
+ DEBUG_COMPILE_r(
+ PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
+ (IV)(first - scan + 1))
+ );
+#endif
+
+
/*
* If there's something expensive in the r.e., find the
* longest literal string that must appear and make it the
Newxz(r->startp, RExC_npar, I32);
Newxz(r->endp, RExC_npar, I32);
- DEBUG_COMPILE_r({
- if (SvIV(re_debug_flags)> (RE_DEBUG_COMPILE | RE_DEBUG_EXECUTE))
- PerlIO_printf(Perl_debug_log,"Final program:\n");
+ DEBUG_r( RX_DEBUG_on(r) );
+ DEBUG_DUMP_r({
+ PerlIO_printf(Perl_debug_log,"Final program:\n");
regdump(r);
});
+ DEBUG_OFFSETS_r(if (r->offsets) {
+ const U32 len = r->offsets[0];
+ U32 i;
+ GET_RE_DEBUG_FLAGS_DECL;
+ PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)r->offsets[0]);
+ for (i = 1; i <= len; i++) {
+ if (r->offsets[i*2-1] || r->offsets[i*2])
+ PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
+ i, (UV)r->offsets[i*2-1], (UV)r->offsets[i*2]);
+ }
+ PerlIO_printf(Perl_debug_log, "\n");
+ });
return(r);
}
else \
num=REG_NODE_NUM(RExC_emit); \
if (RExC_lastnum!=num) \
- PerlIO_printf(Perl_debug_log,"%4d",num); \
+ PerlIO_printf(Perl_debug_log,"|%4d",num); \
else \
- PerlIO_printf(Perl_debug_log,"%4s",""); \
- PerlIO_printf(Perl_debug_log,"%*s%-4s", \
- (int)(10+(depth*2)), "", \
+ PerlIO_printf(Perl_debug_log,"|%4s",""); \
+ PerlIO_printf(Perl_debug_log,"|%*s%-4s", \
+ (int)((depth*2)), "", \
(funcname) \
); \
RExC_lastnum=num; \
case we need to change the emitted regop to an EXACT. */
const char * orig_parse = RExC_parse;
GET_RE_DEBUG_FLAGS_DECL;
+#ifndef DEBUGGING
+ PERL_UNUSED_ARG(depth);
+#endif
+
DEBUG_PARSE("clas");
/* Assume we are going to generate an ANYOF node. */
STRLEN foldlen;
const UV f = to_uni_fold(natvalue, foldbuf, &foldlen);
+#ifdef EBCDIC /* RD t/uni/fold ff and 6b */
+ if (RExC_precomp[0] == ':' &&
+ RExC_precomp[1] == '[' &&
+ (f == 0xDF || f == 0x92)) {
+ f = NATIVE_TO_UNI(f);
+ }
+#endif
/* If folding and foldable and a single
* character, insert also the folded version
* to the charclass. */
if (f != value) {
+#ifdef EBCDIC /* RD tunifold ligatures s,t fb05, fb06 */
+ if ((RExC_precomp[0] == ':' &&
+ RExC_precomp[1] == '[' &&
+ (f == 0xA2 &&
+ (value == 0xFB05 || value == 0xFB06))) ?
+ foldlen == ((STRLEN)UNISKIP(f) - 1) :
+ foldlen == (STRLEN)UNISKIP(f) )
+#else
if (foldlen == (STRLEN)UNISKIP(f))
+#endif
Perl_sv_catpvf(aTHX_ listsv,
"%04"UVxf"\n", f);
else {
dVAR;
register regnode *scan;
GET_RE_DEBUG_FLAGS_DECL;
+#ifndef DEBUGGING
+ PERL_UNUSED_ARG(depth);
+#endif
if (SIZE_ONLY)
return;
#ifdef DEBUGGING
dVAR;
SV * const sv = sv_newmortal();
+ SV *dsv= sv_newmortal();
(void)dumpuntil(r, r->program, r->program + 1, NULL, sv, 0);
/* Header fields of interest. */
- if (r->anchored_substr)
+ if (r->anchored_substr) {
+ RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr),
+ RE_SV_DUMPLEN(r->anchored_substr), 30);
PerlIO_printf(Perl_debug_log,
- "anchored \"%s%.*s%s\"%s at %"IVdf" ",
- PL_colors[0],
- (int)(SvCUR(r->anchored_substr) - (SvTAIL(r->anchored_substr)!=0)),
- SvPVX_const(r->anchored_substr),
- PL_colors[1],
- SvTAIL(r->anchored_substr) ? "$" : "",
+ "anchored %s%s at %"IVdf" ",
+ s, RE_SV_TAIL(r->anchored_substr),
(IV)r->anchored_offset);
- else if (r->anchored_utf8)
+ } else if (r->anchored_utf8) {
+ RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8),
+ RE_SV_DUMPLEN(r->anchored_utf8), 30);
PerlIO_printf(Perl_debug_log,
- "anchored utf8 \"%s%.*s%s\"%s at %"IVdf" ",
- PL_colors[0],
- (int)(SvCUR(r->anchored_utf8) - (SvTAIL(r->anchored_utf8)!=0)),
- SvPVX_const(r->anchored_utf8),
- PL_colors[1],
- SvTAIL(r->anchored_utf8) ? "$" : "",
+ "anchored utf8 %s%s at %"IVdf" ",
+ s, RE_SV_TAIL(r->anchored_utf8),
(IV)r->anchored_offset);
- if (r->float_substr)
+ }
+ if (r->float_substr) {
+ RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr),
+ RE_SV_DUMPLEN(r->float_substr), 30);
PerlIO_printf(Perl_debug_log,
- "floating \"%s%.*s%s\"%s at %"IVdf"..%"UVuf" ",
- PL_colors[0],
- (int)(SvCUR(r->float_substr) - (SvTAIL(r->float_substr)!=0)),
- SvPVX_const(r->float_substr),
- PL_colors[1],
- SvTAIL(r->float_substr) ? "$" : "",
+ "floating %s%s at %"IVdf"..%"UVuf" ",
+ s, RE_SV_TAIL(r->float_substr),
(IV)r->float_min_offset, (UV)r->float_max_offset);
- else if (r->float_utf8)
+ } else if (r->float_utf8) {
+ RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8),
+ RE_SV_DUMPLEN(r->float_utf8), 30);
PerlIO_printf(Perl_debug_log,
- "floating utf8 \"%s%.*s%s\"%s at %"IVdf"..%"UVuf" ",
- PL_colors[0],
- (int)(SvCUR(r->float_utf8) - (SvTAIL(r->float_utf8)!=0)),
- SvPVX_const(r->float_utf8),
- PL_colors[1],
- SvTAIL(r->float_utf8) ? "$" : "",
+ "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
+ s, RE_SV_TAIL(r->float_utf8),
(IV)r->float_min_offset, (UV)r->float_max_offset);
+ }
if (r->check_substr || r->check_utf8)
PerlIO_printf(Perl_debug_log,
r->check_substr == r->float_substr
if (r->reganch & ROPT_EVAL_SEEN)
PerlIO_printf(Perl_debug_log, "with eval ");
PerlIO_printf(Perl_debug_log, "\n");
- if (r->offsets) {
- const U32 len = r->offsets[0];
- GET_RE_DEBUG_FLAGS_DECL;
- DEBUG_OFFSETS_r({
- U32 i;
- PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)r->offsets[0]);
- for (i = 1; i <= len; i++) {
- if (!(SvIV(re_debug_flags) & RE_DEBUG_OLD_OFFSETS)) {
- if (r->offsets[i*2-1] || r->offsets[i*2])
- PerlIO_printf(Perl_debug_log, "%"UVuf":",i);
- else
- continue;
- }
- PerlIO_printf(Perl_debug_log, "%"UVuf"[%"UVuf"] ",
- (UV)r->offsets[i*2-1], (UV)r->offsets[i*2]);
- }
- PerlIO_printf(Perl_debug_log, "\n");
- });
- }
#else
PERL_UNUSED_CONTEXT;
PERL_UNUSED_ARG(r);
if (k == EXACT) {
SV * const dsv = sv_2mortal(newSVpvs(""));
- /* Using is_utf8_string() is a crude hack but it may
- * be the best for now since we have no flag "this EXACTish
- * node was UTF-8" --jhi */
- const bool do_utf8 = is_utf8_string((U8*)STRING(o), STR_LEN(o));
- const char * const s = do_utf8 ?
- pv_uni_display(dsv, (U8*)STRING(o), STR_LEN(o), 60,
- UNI_DISPLAY_REGEX) :
- STRING(o);
- const int len = do_utf8 ?
- strlen(s) :
- STR_LEN(o);
- Perl_sv_catpvf(aTHX_ sv, " <%s%.*s%s>",
- PL_colors[0],
- len, s,
- PL_colors[1]);
+ /* Using is_utf8_string() (via PERL_PV_UNI_DETECT)
+ * is a crude hack but it may be the best for now since
+ * we have no flag "this EXACTish node was UTF-8"
+ * --jhi */
+ const char * const s =
+ pv_pretty(dsv, STRING(o), STR_LEN(o), 60,
+ PL_colors[0], PL_colors[1],
+ PERL_PV_ESCAPE_UNI_DETECT |
+ PERL_PV_PRETTY_ELIPSES |
+ PERL_PV_PRETTY_LTGT
+ );
+ Perl_sv_catpvf(aTHX_ sv, " %s", s );
} else if (k == TRIE) {
Perl_sv_catpvf(aTHX_ sv, "-%s",reg_name[o->flags]);
/* print the details of the trie in dumpuntil instead, as
PERL_UNUSED_CONTEXT;
PERL_UNUSED_ARG(sv);
PERL_UNUSED_ARG(o);
+ PERL_UNUSED_ARG(prog);
#endif /* DEBUGGING */
}
Perl_pregfree(pTHX_ struct regexp *r)
{
dVAR;
-#ifdef DEBUGGING
- SV * const dsv = PERL_DEBUG_PAD_ZERO(0);
-#endif
+
+
+
GET_RE_DEBUG_FLAGS_DECL;
if (!r || (--r->refcnt > 0))
return;
- DEBUG_r(if (re_debug_flags && (SvIV(re_debug_flags) & RE_DEBUG_COMPILE)) {
- const char * const s = (r->reganch & ROPT_UTF8)
- ? pv_uni_display(dsv, (U8*)r->precomp, r->prelen, 60, UNI_DISPLAY_REGEX)
- : pv_display(dsv, r->precomp, r->prelen, 0, 60);
- const int len = SvCUR(dsv);
- if (!PL_colorset)
- reginitcolors();
- PerlIO_printf(Perl_debug_log,
- "%sFreeing REx:%s %s%*.*s%s%s\n",
- PL_colors[4],PL_colors[5],PL_colors[0],
- len, len, s,
- PL_colors[1],
- len > 60 ? "..." : "");
+ DEBUG_COMPILE_r({
+ if (!PL_colorset)
+ reginitcolors();
+ if (RX_DEBUG(r)){
+ SV *dsv= sv_newmortal();
+ RE_PV_QUOTED_DECL(s, (r->reganch & ROPT_UTF8),
+ dsv, r->precomp, r->prelen, 60);
+ PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n",
+ PL_colors[4],PL_colors[5],s);
+ }
});
/* gcov results gave these as non-null 100% of the time, so there's no
case 'n':
break;
case 'T':
- {
+ { /* Aho Corasick add-on structure for a trie node.
+ Used in stclass optimization only */
U32 refcount;
reg_ac_data *aho=(reg_ac_data*)r->data->data[n];
OP_REFCNT_LOCK;
aho->trie=NULL; /* not necessary to free this as it is
handled by the 't' case */
Safefree(r->data->data[n]); /* do this last!!!! */
+ Safefree(r->regstclass);
}
}
break;
case 't':
{
+ /* trie structure. */
U32 refcount;
reg_trie_data *trie=(reg_trie_data*)r->data->data[n];
OP_REFCNT_LOCK;
if (trie->wordlen)
Safefree(trie->wordlen);
#ifdef DEBUGGING
- if (trie->words)
- SvREFCNT_dec((SV*)trie->words);
- if (trie->revcharmap)
- SvREFCNT_dec((SV*)trie->revcharmap);
+ if (RX_DEBUG(r)) {
+ if (trie->words)
+ SvREFCNT_dec((SV*)trie->words);
+ if (trie->revcharmap)
+ SvREFCNT_dec((SV*)trie->revcharmap);
+ }
#endif
Safefree(r->data->data[n]); /* do this last!!!! */
}
/* Where, what. */
if (OP(node) == OPTIMIZED) {
- if (!optstart && (SvIV(re_debug_flags) & RE_DEBUG_OPTIMISE))
+ if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
optstart = node;
else
goto after_print;
after_print:
if (PL_regkind[(U8)op] == BRANCHJ) {
- register const regnode *nnode = (OP(next) == LONGJMP
+ assert(next);
+ {
+ register const regnode *nnode = (OP(next) == LONGJMP
? regnext((regnode *)next)
: next);
- if (last && nnode > last)
- nnode = last;
- DUMPUNTIL(r, start, NEXTOPER(NEXTOPER(node)), nnode, sv, l + 1);
+ if (last && nnode > last)
+ nnode = last;
+ DUMPUNTIL(r, start, NEXTOPER(NEXTOPER(node)), nnode, sv, l + 1);
+ }
}
else if (PL_regkind[(U8)op] == BRANCH) {
+ assert(next);
DUMPUNTIL(r, start, NEXTOPER(node), next, sv, l + 1);
}
else if ( PL_regkind[(U8)op] == TRIE ) {
(int)TRIE_CHARCOUNT(trie),
trie->uniquecharcount,
(IV)TRIE_LASTSTATE(trie)-1,
- trie->minlen, trie->maxlen
+ (int)trie->minlen,
+ (int)trie->maxlen
);
if (trie->bitmap) {
int i;
for (word_idx=0; word_idx < arry_len; word_idx++) {
SV ** const elem_ptr = av_fetch(trie->words,word_idx,0);
- if (elem_ptr) {
- PerlIO_printf(Perl_debug_log, "%*s<%s%s%s>\n",
+ if (elem_ptr)
+ PerlIO_printf(Perl_debug_log, "%*s%s\n",
(int)(2*(l+4)), "",
- PL_colors[0],
- SvPV_nolen_const(*elem_ptr),
- PL_colors[1]
+ pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
+ PL_colors[0], PL_colors[1],
+ (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
+ PERL_PV_PRETTY_ELIPSES |
+ PERL_PV_PRETTY_LTGT
+ )
);
}
- }
node = NEXTOPER(node);
node += regarglen[(U8)op];
NEXTOPER(node) + EXTRA_STEP_2ARGS + 1, sv, l + 1);
}
else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
+ assert(next);
DUMPUNTIL(r, start, NEXTOPER(node) + EXTRA_STEP_2ARGS,
next, sv, l + 1);
}
projects / p5sagit/p5-mst-13.2.git / blobdiff