SPAGAIN;
qr_ref = POPs;
PUTBACK;
- if (SvTRUE(ERRSV))
{
- Safefree(pRExC_state->code_blocks);
- Perl_croak(aTHX_ "%s", SvPVx_nolen_const(ERRSV));
+ SV * const errsv = ERRSV;
+ if (SvTRUE_NN(errsv))
+ {
+ Safefree(pRExC_state->code_blocks);
+ /* use croak_sv ? */
+ Perl_croak_nocontext("%s", SvPV_nolen_const(errsv));
+ }
}
assert(SvROK(qr_ref));
qr = SvRV(qr_ref);
if (flags & RXapif_FETCH) {
return reg_named_buff_fetch(rx, key, flags);
} else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
return NULL;
} else if (flags & RXapif_EXISTS) {
return reg_named_buff_exists(rx, key, flags)
PERL_UNUSED_ARG(value);
if (!PL_localizing)
- Perl_croak_no_modify(aTHX);
+ Perl_croak_no_modify();
}
I32
* And benchmarks show that caching gives better results. We also test
* here if the code point is within the bounds of the list. These tests
* replace others that would have had to be made anyway to make sure that
- * the array bounds were not exceeded, and give us extra information at the
- * same time */
+ * the array bounds were not exceeded, and these give us extra information
+ * at the same time */
if (cp >= array[mid]) {
if (cp >= array[highest_element]) {
return highest_element;
}
#endif
-#if 0
+#ifdef PERL_ARGS_ASSERT__INVLIST_DUMP
void
-S_invlist_dump(pTHX_ SV* const invlist, const char * const header)
+Perl__invlist_dump(pTHX_ SV* const invlist, const char * const header)
{
/* Dumps out the ranges in an inversion list. The string 'header'
* if present is output on a line before the first range */
UV start, end;
+ PERL_ARGS_ASSERT__INVLIST_DUMP;
+
if (header && strlen(header)) {
PerlIO_printf(Perl_debug_log, "%s\n", header);
}
if (end == UV_MAX) {
PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. INFINITY\n", start);
}
+ else if (end != start) {
+ PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. 0x%04"UVXf"\n",
+ start, end);
+ }
else {
- PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. 0x%04"UVXf"\n", start, end);
+ PerlIO_printf(Perl_debug_log, "0x%04"UVXf"\n", start);
}
}
}
#define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
#define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
-STATIC I32
-S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
+PERL_STATIC_INLINE I32
+S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value, SV *free_me)
{
dVAR;
I32 namedclass = OOB_NAMEDCLASS;
the class closes */
while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
RExC_parse++;
- Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
+ SvREFCNT_dec(free_me);
+ vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
}
} else {
/* Maternal grandfather:
return namedclass;
}
-STATIC void
-S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
-{
- dVAR;
-
- PERL_ARGS_ASSERT_CHECKPOSIXCC;
-
- if (POSIXCC(UCHARAT(RExC_parse))) {
- const char *s = RExC_parse;
- const char c = *s++;
-
- while (isALNUM(*s))
- s++;
- if (*s && c == *s && s[1] == ']') {
- ckWARN3reg(s+2,
- "POSIX syntax [%c %c] belongs inside character classes",
- c, c);
-
- /* [[=foo=]] and [[.foo.]] are still future. */
- if (POSIXCC_NOTYET(c)) {
- /* adjust RExC_parse so the error shows after
- the class closes */
- while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
- NOOP;
- Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
- }
- }
- }
-}
-
/* Generate the code to add a full posix character <class> to the bracketed
* character class given by <node>. (<node> is needed only under locale rules)
* destlist is the inversion list for non-locale rules that this class is
nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
if (!SIZE_ONLY && POSIXCC(nextvalue))
- checkposixcc(pRExC_state);
+ {
+ const char *s = RExC_parse;
+ const char c = *s++;
+
+ while (isALNUM(*s))
+ s++;
+ if (*s && c == *s && s[1] == ']') {
+ ckWARN3reg(s+2,
+ "POSIX syntax [%c %c] belongs inside character classes",
+ c, c);
+
+ /* [[=foo=]] and [[.foo.]] are still future. */
+ if (POSIXCC_NOTYET(c)) {
+ /* adjust RExC_parse so the error shows after
+ the class closes */
+ while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
+ NOOP;
+ SvREFCNT_dec(listsv);
+ vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
+ }
+ }
+ }
/* allow 1st char to be ] (allowing it to be - is dealt with later) */
if (UCHARAT(RExC_parse) == ']')
nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
if (value == '[' && POSIXCC(nextvalue))
- namedclass = regpposixcc(pRExC_state, value);
+ namedclass = regpposixcc(pRExC_state, value, listsv);
else if (value == '\\') {
if (UTF) {
value = utf8n_to_uvchr((U8*)RExC_parse,
Safefree(name);
}
RExC_parse = e + 1;
- namedclass = ANYOF_MAX; /* no official name, but it's named */
+ namedclass = ANYOF_UNIPROP; /* no official name, but it's named */
/* \p means they want Unicode semantics */
RExC_uni_semantics = 1;
DO_N_POSIX(ret, namedclass, posixes,
PL_PosixXDigit, PL_XPosixXDigit);
break;
- case ANYOF_MAX:
- /* this is to handle \p and \P */
+ case ANYOF_UNIPROP: /* this is to handle \p and \P */
break;
default:
vFAIL("Invalid [::] class");
*flagp |= HASWIDTH|SIMPLE;
break;
- case ANYOF_MAX:
+ case ANYOF_UNIPROP:
break;
case ANYOF_NBLANK:
ret = reg_node(pRExC_state, op);
- if (PL_regkind[op] == POSIXD) {
+ if (PL_regkind[op] == POSIXD || PL_regkind[op] == NPOSIXD) {
if (! SIZE_ONLY) {
FLAGS(ret) = arg;
}
Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
}
- else if (k == POSIXD) {
+ else if (k == POSIXD || k == NPOSIXD) {
U8 index = FLAGS(o) * 2;
if (index > (sizeof(anyofs) / sizeof(anyofs[0]))) {
Perl_sv_catpvf(aTHX_ sv, "[illegal type=%d])", index);
Safefree(r->substrs);
}
RX_MATCH_COPY_FREE(rx);
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
SvREFCNT_dec(r->saved_copy);
#endif
Safefree(r->offs);
anchored or float namesakes, and don't hold a second reference. */
}
RX_MATCH_COPIED_off(ret_x);
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
ret->saved_copy = NULL;
#endif
ret->mother_re = ReREFCNT_inc(r->mother_re ? r->mother_re : rx);
ret->subbeg = SAVEPVN(ret->subbeg, ret->sublen);
else
ret->subbeg = NULL;
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
ret->saved_copy = NULL;
#endif
- regnext - dig the "next" pointer out of a node
*/
regnode *
-Perl_regnext(pTHX_ register regnode *p)
+Perl_regnext(pTHX_ regnode *p)
{
dVAR;
I32 offset;
PL_reg_leftiter = 0;
PL_reg_poscache = NULL;
PL_reg_poscache_size = 0;
-#ifdef PERL_OLD_COPY_ON_WRITE
+#ifdef PERL_ANY_COW
PL_nrs = NULL;
#endif
https://perl5.git.perl.org / perl5.git / blobdiff