char *parse; /* Input-scan pointer. */
char *copy_start; /* start of copy of input within
constructed parse string */
+ char *save_copy_start; /* Provides one level of saving
+ and restoring 'copy_start' */
char *copy_start_in_input; /* Position in input string
corresponding to copy_start */
SSize_t whilem_seen; /* number of WHILEM in this expr */
#define RExC_precomp (pRExC_state->precomp)
#define RExC_copy_start_in_input (pRExC_state->copy_start_in_input)
#define RExC_copy_start_in_constructed (pRExC_state->copy_start)
+#define RExC_save_copy_start_in_constructed (pRExC_state->save_copy_start)
#define RExC_precomp_end (pRExC_state->precomp_end)
#define RExC_rx_sv (pRExC_state->rx_sv)
#define RExC_rx (pRExC_state->rx)
} STMT_END
/* Setting this to NULL is a signal to not output warnings */
-#define TURN_OFF_WARNINGS_IN_SUBSTITUTE_PARSE RExC_copy_start_in_constructed = NULL
-#define RESTORE_WARNINGS RExC_copy_start_in_constructed = RExC_precomp
+#define TURN_OFF_WARNINGS_IN_SUBSTITUTE_PARSE \
+ STMT_START { \
+ RExC_save_copy_start_in_constructed = RExC_copy_start_in_constructed;\
+ RExC_copy_start_in_constructed = NULL; \
+ } STMT_END
+#define RESTORE_WARNINGS \
+ RExC_copy_start_in_constructed = RExC_save_copy_start_in_constructed
/* Since a warning can be generated multiple times as the input is reparsed, we
* output it the first time we come to that point in the parse, but suppress it
const char* name;
name = get_regex_charset_name(RExC_rx->extflags, &len);
- if strEQ(name, DEPENDS_PAT_MODS) { /* /d under UTF-8 => /u */
+ if (strEQ(name, DEPENDS_PAT_MODS)) { /* /d under UTF-8 => /u */
assert(RExC_utf8);
name = UNICODE_PAT_MODS;
len = sizeof(UNICODE_PAT_MODS) - 1;
RExC_sawback = 1;
ret = reganode(pRExC_state,
((! FOLD)
- ? NREF
+ ? REFN
: (ASCII_FOLD_RESTRICTED)
- ? NREFFA
+ ? REFFAN
: (AT_LEAST_UNI_SEMANTICS)
- ? NREFFU
+ ? REFFUN
: (LOC)
- ? NREFFL
- : NREFF),
+ ? REFFLN
+ : REFFN),
num);
*flagp |= HASWIDTH;
RExC_rxi->data->data[num]=(void*)sv_dat;
SvREFCNT_inc_simple_void_NN(sv_dat);
}
- ret = reganode(pRExC_state, NGROUPP, num);
+ ret = reganode(pRExC_state, GROUPPN, num);
goto insert_if_check_paren;
}
else if (memBEGINs(RExC_parse,
loopdone: /* Jumped to when encounters something that shouldn't be
in the node */
- /* Free up any over-allocated space */
- change_engine_size(pRExC_state, - (initial_size - STR_SZ(len)));
+ /* Free up any over-allocated space; cast is to silence bogus
+ * warning in MS VC */
+ change_engine_size(pRExC_state,
+ - (Ptrdiff_t) (initial_size - STR_SZ(len)));
/* I (khw) don't know if you can get here with zero length, but the
* old code handled this situation by creating a zero-length EXACT
literal
);
}
- else if isMNEMONIC_CNTRL(value) {
+ else if (isMNEMONIC_CNTRL(value)) {
vWARN4(RExC_parse,
"\"%.*s\" is more clearly written simply as \"%s\"",
(int) (RExC_parse - rangebegin),
name_list= RExC_paren_name_list;
}
if (name_list) {
- if ( k != REF || (OP(o) < NREF)) {
+ if ( k != REF || (OP(o) < REFN)) {
SV **name= av_fetch(name_list, parno, 0 );
if (name)
Perl_sv_catpvf(aTHX_ sv, " '%" SVf "'", SVfARG(*name));
RESTORE_CONTEXT;
}
+STATIC SV *
+S_get_fq_name(pTHX_
+ const char * const name, /* The first non-blank in the \p{}, \P{} */
+ const Size_t name_len, /* Its length in bytes, not including any trailing space */
+ const bool is_utf8, /* ? Is 'name' encoded in UTF-8 */
+ const bool has_colon_colon
+ )
+{
+ /* Returns a mortal SV containing the fully qualified version of the input
+ * name */
+
+ SV * fq_name;
+
+ fq_name = newSVpvs_flags("", SVs_TEMP);
+
+ /* Use the current package if it wasn't included in our input */
+ if (! has_colon_colon) {
+ const HV * pkg = (IN_PERL_COMPILETIME)
+ ? PL_curstash
+ : CopSTASH(PL_curcop);
+ const char* pkgname = HvNAME(pkg);
+
+ Perl_sv_catpvf(aTHX_ fq_name, "%" UTF8f,
+ UTF8fARG(is_utf8, strlen(pkgname), pkgname));
+ sv_catpvs(fq_name, "::");
+ }
+
+ Perl_sv_catpvf(aTHX_ fq_name, "%" UTF8f,
+ UTF8fARG(is_utf8, name_len, name));
+ return fq_name;
+}
+
SV *
Perl_parse_uniprop_string(pTHX_
it is the definition. Otherwise it is a
string containing the fully qualified sub
name of 'name' */
+ SV * fq_name = NULL; /* For user-defined properties, the fully
+ qualified name */
bool invert_return = FALSE; /* ? Do we need to complement the result before
returning it */
pos_in_brackets = strchr("([<)]>)]>", open);
close = (pos_in_brackets) ? pos_in_brackets[3] : open;
- if ( name[name_len-1] != close
+ if ( i >= name_len
+ || name[name_len-1] != close
|| (escaped && name[name_len-2] != '\\'))
{
sv_catpvs(msg, "Unicode property wildcard not terminated");
if (could_be_user_defined) {
CV* user_sub;
+ /* If the user defined property returns the empty string, it could
+ * easily be because the pattern is being compiled before the data it
+ * actually needs to compile is available. This could be argued to be
+ * a bug in the perl code, but this is a change of behavior for Perl,
+ * so we handle it. This means that intentionally returning nothing
+ * will not be resolved until runtime */
+ bool empty_return = FALSE;
+
/* Here, the name could be for a user defined property, which are
* implemented as subs. */
user_sub = get_cvn_flags(name, name_len, 0);
if (user_sub) {
+ const char insecure[] = "Insecure user-defined property";
/* Here, there is a sub by the correct name. Normally we call it
* to get the property definition */
dSP;
SV * user_sub_sv = MUTABLE_SV(user_sub);
SV * error; /* Any error returned by calling 'user_sub' */
- SV * fq_name; /* Fully qualified property name */
+ SV * key; /* The key into the hash of user defined sub names
+ */
SV * placeholder;
- char to_fold_string[] = "0:"; /* The 0 gets overwritten with the
- actual value */
SV ** saved_user_prop_ptr; /* Hash entry for this property */
/* How many times to retry when another thread is in the middle of
/* If we get here, we know this property is user-defined */
*user_defined_ptr = TRUE;
- /* We refuse to call a tainted subroutine; returning an error
- * instead */
+ /* We refuse to call a potentially tainted subroutine; returning an
+ * error instead */
if (TAINT_get) {
if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
- sv_catpvs(msg, "Insecure user-defined property");
+ sv_catpvn(msg, insecure, sizeof(insecure) - 1);
goto append_name_to_msg;
}
* should the need arise, passing the /i status as a parameter.
*
* We start by constructing the hash key name, consisting of the
- * fully qualified subroutine name */
- fq_name = sv_2mortal(newSV(10)); /* 10 is just a guess */
- (void) cv_name(user_sub, fq_name, 0);
-
- /* But precede the sub name in the key with the /i status, so that
- * there is a key for /i and a different key for non-/i */
- to_fold_string[0] = to_fold + '0';
- sv_insert(fq_name, 0, 0, to_fold_string, 2);
+ * fully qualified subroutine name, preceded by the /i status, so
+ * that there is a key for /i and a different key for non-/i */
+ key = newSVpvn(((to_fold) ? "1" : "0"), 1);
+ fq_name = S_get_fq_name(aTHX_ name, name_len, is_utf8,
+ non_pkg_begin != 0);
+ sv_catsv(key, fq_name);
+ sv_2mortal(key);
/* We only call the sub once throughout the life of the program
* (with the /i, non-/i exception noted above). That means the
/* If we have an entry for this key, the subroutine has already
* been called once with this /i status. */
saved_user_prop_ptr = hv_fetch(PL_user_def_props,
- SvPVX(fq_name), SvCUR(fq_name), 0);
+ SvPVX(key), SvCUR(key), 0);
if (saved_user_prop_ptr) {
/* If the saved result is an inversion list, it is the valid
* */
SWITCH_TO_GLOBAL_CONTEXT;
placeholder= newSVuv(PTR2IV(ORIGINAL_CONTEXT));
- (void) hv_store_ent(PL_user_def_props, fq_name, placeholder, 0);
+ (void) hv_store_ent(PL_user_def_props, key, placeholder, 0);
RESTORE_CONTEXT;
/* Now that we have a placeholder, we can let other threads
USER_PROP_MUTEX_UNLOCK;
/* Make sure the placeholder always gets destroyed */
- SAVEDESTRUCTOR_X(S_delete_recursion_entry, SvPVX(fq_name));
+ SAVEDESTRUCTOR_X(S_delete_recursion_entry, SvPVX(key));
PUSHMARK(SP);
SAVETMPS;
XPUSHs(boolSV(to_fold));
PUTBACK;
+ /* The following block was taken from swash_init(). Presumably
+ * they apply to here as well, though we no longer use a swash --
+ * khw */
+ SAVEHINTS();
+ save_re_context();
+ /* We might get here via a subroutine signature which uses a utf8
+ * parameter name, at which point PL_subname will have been set
+ * but not yet used. */
+ save_item(PL_subname);
+
(void) call_sv(user_sub_sv, G_EVAL|G_SCALAR);
SPAGAIN;
error = ERRSV;
- if (SvTRUE(error)) {
+ if (TAINT_get || SvTRUE(error)) {
if (SvCUR(msg) > 0) sv_catpvs(msg, "; ");
- sv_catpvs(msg, "Error \"");
- sv_catsv(msg, error);
- sv_catpvs(msg, "\"");
+ if (SvTRUE(error)) {
+ sv_catpvs(msg, "Error \"");
+ sv_catsv(msg, error);
+ sv_catpvs(msg, "\"");
+ }
+ if (TAINT_get) {
+ if (SvTRUE(error)) sv_catpvs(msg, "; ");
+ sv_catpvn(msg, insecure, sizeof(insecure) - 1);
+ }
+
if (name_len > 0) {
sv_catpvs(msg, " in expansion of ");
Perl_sv_catpvf(aTHX_ msg, "%" UTF8f, UTF8fARG(is_utf8,
prop_definition = NULL;
}
else { /* G_SCALAR guarantees a single return value */
+ SV * contents = POPs;
/* The contents is supposed to be the expansion of the property
- * definition. Call a function to check for valid syntax and
- * handle it */
- prop_definition = handle_user_defined_property(name, name_len,
+ * definition. If the definition is deferrable, and we got an
+ * empty string back, set a flag to later defer it (after clean
+ * up below). */
+ if ( deferrable
+ && (! SvPOK(contents) || SvCUR(contents) == 0))
+ {
+ empty_return = TRUE;
+ }
+ else { /* Otherwise, call a function to check for valid syntax,
+ and handle it */
+
+ prop_definition = handle_user_defined_property(
+ name, name_len,
is_utf8, to_fold, runtime,
deferrable,
- POPs, user_defined_ptr,
+ contents, user_defined_ptr,
msg,
level);
+ }
}
/* Here, we have the results of the expansion. Delete the
* and add the permanent entry */
USER_PROP_MUTEX_LOCK;
- S_delete_recursion_entry(aTHX_ SvPVX(fq_name));
-
- if (! prop_definition || is_invlist(prop_definition)) {
+ S_delete_recursion_entry(aTHX_ SvPVX(key));
+ if ( ! empty_return
+ && (! prop_definition || is_invlist(prop_definition)))
+ {
/* If we got success we use the inversion list defining the
* property; otherwise use the error message */
SWITCH_TO_GLOBAL_CONTEXT;
(void) hv_store_ent(PL_user_def_props,
- fq_name,
+ key,
((prop_definition)
? newSVsv(prop_definition)
: newSVsv(msg)),
LEAVE;
POPSTACK;
+ if (empty_return) {
+ goto definition_deferred;
+ }
+
if (prop_definition) {
/* If the definition is for something not known at this time,
* NV. */
NV value;
+ SSize_t value_len = lookup_len - equals_pos;
/* Get the value */
- if (my_atof3(lookup_name + equals_pos, &value,
- lookup_len - equals_pos)
+ if ( value_len <= 0
+ || my_atof3(lookup_name + equals_pos, &value,
+ value_len)
!= lookup_name + lookup_len)
{
goto failed;
definition_deferred:
/* Here it could yet to be defined, so defer evaluation of this
- * until its needed at runtime. */
- prop_definition = newSVpvs_flags("", SVs_TEMP);
-
- /* To avoid any ambiguity, the package is always specified.
- * Use the current one if it wasn't included in our input */
- if (non_pkg_begin == 0) {
- const HV * pkg = (IN_PERL_COMPILETIME)
- ? PL_curstash
- : CopSTASH(PL_curcop);
- const char* pkgname = HvNAME(pkg);
-
- Perl_sv_catpvf(aTHX_ prop_definition, "%" UTF8f,
- UTF8fARG(is_utf8, strlen(pkgname), pkgname));
- sv_catpvs(prop_definition, "::");
+ * until its needed at runtime. We need the fully qualified property name
+ * to avoid ambiguity, and a trailing newline */
+ if (! fq_name) {
+ fq_name = S_get_fq_name(aTHX_ name, name_len, is_utf8,
+ non_pkg_begin != 0 /* If has "::" */
+ );
}
-
- Perl_sv_catpvf(aTHX_ prop_definition, "%" UTF8f,
- UTF8fARG(is_utf8, name_len, name));
- sv_catpvs(prop_definition, "\n");
+ sv_catpvs(fq_name, "\n");
*user_defined_ptr = TRUE;
- return prop_definition;
+ return fq_name;
}
#endif
https://perl5.git.perl.org / perl5.git / blobdiff