return 1;
if (!(cl->flags & ANYOF_UNICODE_ALL))
return 0;
- if (!ANYOF_BITMAP_TESTALLSET(cl))
+ if (!ANYOF_BITMAP_TESTALLSET((const void*)cl))
return 0;
return 1;
}
#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 ** 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++ ) {
( 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 ** const 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 ),
+ 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;
/*
for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
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 );
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 );
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;
STR_LEN(convert)++;
} else {
+#ifdef DEBUGGING
if (state>1)
DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n"));
+#endif
break;
}
}
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;
}
}
}
#ifdef TRIE_STUDY_OPT
else if (OP(scan) == TRIE) {
- reg_trie_data *trie=RExC_rx->data->data[ ARG(scan) ];
+ reg_trie_data *trie = (reg_trie_data*)RExC_rx->data->data[ ARG(scan) ];
min += trie->minlen;
delta += (trie->maxlen - trie->minlen);
flags &= ~SCF_DO_STCLASS; /* xxx */
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);
}
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);
}
I32 min;
I32 max = REG_INFTY;
char *parse_start;
+ const char *maxpos = NULL;
GET_RE_DEBUG_FLAGS_DECL;
DEBUG_PARSE("piec");
op = *RExC_parse;
if (op == '{' && regcurly(RExC_parse)) {
- const char *maxpos = NULL;
+ maxpos = NULL;
parse_start = RExC_parse; /* MJD */
next = RExC_parse + 1;
while (isDIGIT(*next) || *next == ',') {
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
- && r->check_utf8 == r->float_utf8
- ? "(checking floating" : "(checking anchored");
+ (const char *)
+ (r->check_substr == r->float_substr
+ && r->check_utf8 == r->float_utf8
+ ? "(checking floating" : "(checking anchored"));
if (r->reganch & ROPT_NOSCAN)
PerlIO_printf(Perl_debug_log, " noscan");
if (r->reganch & ROPT_CHECK_ALL)
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 (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");
- });
- }
#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_COMPILE_r(if (RX_DEBUG(r)){
- 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
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];