if (exp == NULL)
FAIL("NULL regexp argument");
- /* XXXX This looks very suspicious... */
- if (pm->op_pmdynflags & PMdf_CMP_UTF8)
- RExC_utf8 = 1;
- else
- RExC_utf8 = 0;
+ RExC_utf8 = pm->op_pmdynflags & PMdf_CMP_UTF8;
RExC_precomp = exp;
- DEBUG_r(if (!PL_colorset) reginitcolors());
- DEBUG_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]));
+ DEBUG_r({
+ if (!PL_colorset) reginitcolors();
+ 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]);
+ });
RExC_flags16 = pm->op_pmflags;
RExC_sawback = 0;
register char *p;
char *oldp, *s;
STRLEN numlen;
- STRLEN ulen;
- U8 tmpbuf[UTF8_MAXLEN*2+1];
+ STRLEN foldlen;
+ U8 tmpbuf[UTF8_MAXLEN_FOLD+1], *foldbuf;
parse_start = RExC_parse - 1;
case '\\':
switch (*++p) {
case 'A':
+ case 'C':
+ case 'X':
case 'G':
case 'Z':
case 'z':
if (RExC_flags16 & PMf_EXTENDED)
p = regwhite(p, RExC_end);
if (UTF && FOLD) {
- toLOWER_uni(ender, tmpbuf, &ulen);
- ender = utf8_to_uvchr(tmpbuf, 0);
+ /* Prime the casefolded buffer. */
+ ender = toFOLD_uni(ender, tmpbuf, &foldlen);
}
if (ISMULT2(p)) { /* Back off on ?+*. */
if (len)
p = oldp;
- else if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(ender)) && UTF) {
- reguni(pRExC_state, ender, s, &numlen);
- s += numlen;
- len += numlen;
+ else if (UTF) {
+ if (FOLD) {
+ /* Emit all the Unicode characters. */
+ for (foldbuf = tmpbuf;
+ foldlen;
+ foldlen -= numlen) {
+ ender = utf8_to_uvchr(foldbuf, &numlen);
+ reguni(pRExC_state, ender, s, &numlen);
+ s += numlen;
+ len += numlen;
+ foldbuf += numlen;
+ }
+ }
+ else {
+ reguni(pRExC_state, ender, s, &numlen);
+ s += numlen;
+ len += numlen;
+ }
}
else {
len++;
}
break;
}
- if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(ender)) && UTF) {
- reguni(pRExC_state, ender, s, &numlen);
- s += numlen;
- len += numlen - 1;
+ if (UTF) {
+ if (FOLD) {
+ /* Emit all the Unicode characters. */
+ for (foldbuf = tmpbuf;
+ foldlen;
+ foldlen -= numlen) {
+ ender = utf8_to_uvchr(foldbuf, &numlen);
+ reguni(pRExC_state, ender, s, &numlen);
+ s += numlen;
+ len += numlen;
+ foldbuf += numlen;
+ }
+ }
+ else {
+ reguni(pRExC_state, ender, s, &numlen);
+ s += numlen;
+ len += numlen;
+ }
+ len--;
}
else
REGC(ender, s++);
break;
}
- if (PL_encoding && PL_regkind[(U8)OP(ret)] == EXACT && !RExC_utf8) {
+ /* If the encoding pragma is in effect recode the text of
+ * any EXACT-kind nodes. */
+ if (PL_encoding && PL_regkind[(U8)OP(ret)] == EXACT) {
STRLEN oldlen = STR_LEN(ret);
SV *sv = sv_2mortal(newSVpvn(STRING(ret), oldlen));
- char *s = Perl_sv_recode_to_utf8(aTHX_ sv, PL_encoding);
- STRLEN newlen = SvCUR(sv);
- if (!SIZE_ONLY) {
- DEBUG_r(PerlIO_printf(Perl_debug_log, "recode %*s to %*s\n",
- oldlen, STRING(ret), newlen, s));
- Copy(s, STRING(ret), newlen, char);
- STR_LEN(ret) += newlen - oldlen;
- RExC_emit += STR_SZ(newlen) - STR_SZ(oldlen);
- } else
- RExC_size += STR_SZ(newlen) - STR_SZ(oldlen);
- RExC_utf8 = 1;
+
+ if (RExC_utf8)
+ SvUTF8_on(sv);
+ if (sv_utf8_downgrade(sv, TRUE)) {
+ char *s = Perl_sv_recode_to_utf8(aTHX_ sv, PL_encoding);
+ STRLEN newlen = SvCUR(sv);
+
+ if (!SIZE_ONLY) {
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "recode %*s to %*s\n",
+ (int)oldlen, STRING(ret),
+ (int)newlen, s));
+ Copy(s, STRING(ret), newlen, char);
+ STR_LEN(ret) += newlen - oldlen;
+ RExC_emit += STR_SZ(newlen) - STR_SZ(oldlen);
+ } else
+ RExC_size += STR_SZ(newlen) - STR_SZ(oldlen);
+ }
}
return(ret);
SV *listsv = Nullsv;
register char *e;
UV n;
- bool optimize_invert = TRUE;
+ bool optimize_invert = TRUE;
+ AV* unicode_alternate = 0;
ret = reganode(pRExC_state, ANYOF, 0);
}
else
#endif
- for (i = prevvalue; i <= ceilvalue; i++)
- ANYOF_BITMAP_SET(ret, i);
+ for (i = prevvalue; i <= ceilvalue; i++)
+ ANYOF_BITMAP_SET(ret, i);
}
- if (value > 255) {
+ if (value > 255 || UTF) {
ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
if (prevvalue < value)
Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
(UV)prevvalue, (UV)value);
- else if (prevvalue == value)
+ else if (prevvalue == value) {
Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
(UV)value);
+ if (FOLD) {
+ U8 tmpbuf [UTF8_MAXLEN+1];
+ U8 foldbuf[UTF8_MAXLEN_FOLD+1];
+ STRLEN foldlen;
+ UV f;
+
+ uvchr_to_utf8(tmpbuf, value);
+ to_utf8_fold(tmpbuf, foldbuf, &foldlen);
+ f = utf8_to_uvchr(foldbuf, 0);
+
+ /* If folding and foldable and a single
+ * character, insert also the folded version
+ * to the charclass. */
+ if (f != value) {
+ if (foldlen == UNISKIP(f))
+ Perl_sv_catpvf(aTHX_ listsv,
+ "%04"UVxf"\n", f);
+ else {
+ /* Any multicharacter foldings
+ * require the following transform:
+ * [ABCDEF] -> (?:[ABCabcDEFd]|pq|rst)
+ * where E folds into "pq" and F folds
+ * into "rst", all other characters
+ * fold to single characters. We save
+ * away these multicharacter foldings,
+ * to be later saved as part of the
+ * additional "s" data. */
+ SV *sv;
+
+ if (!unicode_alternate)
+ unicode_alternate = newAV();
+ sv = newSVpvn((char*)foldbuf, foldlen);
+ SvUTF8_on(sv);
+ av_push(unicode_alternate, sv);
+ }
+ }
+
+ /* If folding and the value is one of the Greek
+ * sigmas insert a few more sigmas to make the
+ * folding rules of the sigmas to work right.
+ * Note that not all the possible combinations
+ * are handled here: some of them are handled
+ * by the standard folding rules, and some of
+ * them (literal or EXACTF cases) are handled
+ * during runtime in regexec.c:S_find_byclass(). */
+ if (value == UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA) {
+ Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
+ (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA);
+ Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
+ (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
+ }
+ else if (value == UNICODE_GREEK_CAPITAL_LETTER_SIGMA)
+ Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
+ (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
+ }
+ }
}
}
AV *av = newAV();
SV *rv;
+ /* The 0th element stores the character class description
+ * in its textual form: used later (regexec.c:Perl_regclass_swatch())
+ * to initialize the appropriate swash (which gets stored in
+ * the 1st element), and also useful for dumping the regnode.
+ * The 2nd element stores the multicharacter foldings,
+ * used later (regexec.c:s_reginclasslen()). */
av_store(av, 0, listsv);
av_store(av, 1, NULL);
+ av_store(av, 2, (SV*)unicode_alternate);
rv = newRV_noinc((SV*)av);
n = add_data(pRExC_state, 1, "s");
RExC_rx->data->data[n] = (void*)rv;
{
SV *lv;
- SV *sw = regclass_swash(o, FALSE, &lv);
+ SV *sw = regclass_swash(o, FALSE, &lv, 0);
if (lv) {
if (sw) {
void
Perl_pregfree(pTHX_ struct regexp *r)
{
- DEBUG_r(if (!PL_colorset) reginitcolors());
+#ifdef DEBUGGING
+ SV *dsv = PERL_DEBUG_PAD_ZERO(0);
+#endif
if (!r || (--r->refcnt > 0))
return;
- DEBUG_r(PerlIO_printf(Perl_debug_log,
- "%sFreeing REx:%s `%s%.60s%s%s'\n",
- PL_colors[4],PL_colors[5],PL_colors[0],
- r->precomp,
- PL_colors[1],
- (strlen(r->precomp) > 60 ? "..." : "")));
+ DEBUG_r({
+ bool utf8 = r->reganch & ROPT_UTF8;
+ char *s = pv_uni_display(dsv, (U8*)r->precomp, r->prelen, 60,
+ UNI_DISPLAY_ISPRINT);
+ 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 ? "..." : "");
+ });
if (r->precomp)
Safefree(r->precomp);
new_comppad = NULL;
break;
case 'n':
- break;
+ break;
default:
Perl_croak(aTHX_ "panic: regfree data code '%c'", r->data->what[n]);
}