XEdpoM |struct refcounted_he *|refcounted_he_new \
|NULLOK struct refcounted_he *const parent \
|NULLOK SV *const key|NULLOK SV *const value
+#if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT)
+s |struct refcounted_he * |refcounted_he_new_common \
+ |NULLOK struct refcounted_he *const parent \
+ |NN const char *const key_p \
+ |const STRLEN key_len|const char flags \
+ |char value_type|NN const void *value \
+ |const STRLEN value_len
+#endif
Abmd |SV** |hv_store |NULLOK HV *hv|NULLOK const char *key \
|I32 klen|NULLOK SV *val|U32 hash
Abmd |HE* |hv_store_ent |NULLOK HV *hv|NULLOK SV *key|NULLOK SV *val\
Apon |void |sys_init |NN int* argc|NN char*** argv
Apon |void |sys_init3 |NN int* argc|NN char*** argv|NN char*** env
Apon |void |sys_term
-ApM |const char *|fetch_cop_label|NULLOK struct refcounted_he *const chain \
+ApoM |const char *|fetch_cop_label|NULLOK struct refcounted_he *const chain \
|NULLOK STRLEN *len|NULLOK U32 *flags
+ApoM |struct refcounted_he *|store_cop_label \
+ |NULLOK struct refcounted_he *const chain|NN const char *label
END_EXTERN_C
/*
#define hv_iternext_flags Perl_hv_iternext_flags
#define hv_iterval Perl_hv_iterval
#define hv_ksplit Perl_hv_ksplit
+#if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define refcounted_he_new_common S_refcounted_he_new_common
+#endif
+#endif
#define hv_undef Perl_hv_undef
#define ibcmp Perl_ibcmp
#define ibcmp_locale Perl_ibcmp_locale
#ifdef PERL_CORE
#define boot_core_mro Perl_boot_core_mro
#endif
-#define fetch_cop_label Perl_fetch_cop_label
#define ck_anoncode Perl_ck_anoncode
#define ck_bitop Perl_ck_bitop
#define ck_chdir Perl_ck_chdir
#endif
#if defined(PERL_CORE) || defined(PERL_EXT)
#endif
+#if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT)
+#ifdef PERL_CORE
+#define refcounted_he_new_common(a,b,c,d,e,f,g) S_refcounted_he_new_common(aTHX_ a,b,c,d,e,f,g)
+#endif
+#endif
#define hv_undef(a) Perl_hv_undef(aTHX_ a)
#define ibcmp(a,b,c) Perl_ibcmp(aTHX_ a,b,c)
#define ibcmp_locale(a,b,c) Perl_ibcmp_locale(aTHX_ a,b,c)
#ifdef PERL_CORE
#define boot_core_mro() Perl_boot_core_mro(aTHX)
#endif
-#define fetch_cop_label(a,b,c) Perl_fetch_cop_label(aTHX_ a,b,c)
#define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a)
#define ck_bitop(a) Perl_ck_bitop(aTHX_ a)
#define ck_chdir(a) Perl_ck_chdir(aTHX_ a)
Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent,
SV *const key, SV *const value) {
dVAR;
- struct refcounted_he *he;
STRLEN key_len;
const char *key_p = SvPV_const(key, key_len);
STRLEN value_len = 0;
const char *value_p = NULL;
char value_type;
char flags;
- STRLEN key_offset;
- U32 hash;
bool is_utf8 = SvUTF8(key) ? TRUE : FALSE;
if (SvPOK(value)) {
value_type = HVrhek_PV;
} else if (SvIOK(value)) {
- value_type = HVrhek_IV;
+ value_type = SvUOK((SV*)value) ? HVrhek_UV : HVrhek_IV;
} else if (value == &PL_sv_placeholder) {
value_type = HVrhek_delete;
} else if (!SvOK(value)) {
}
if (value_type == HVrhek_PV) {
+ /* Do it this way so that the SvUTF8() test is after the SvPV, in case
+ the value is overloaded, and doesn't yet have the UTF-8flag set. */
value_p = SvPV_const(value, value_len);
- key_offset = value_len + 2;
- } else {
- value_len = 0;
- key_offset = 1;
+ if (SvUTF8(value))
+ value_type = HVrhek_PV_UTF8;
}
+ flags = value_type;
+
+ if (is_utf8) {
+ /* Hash keys are always stored normalised to (yes) ISO-8859-1.
+ As we're going to be building hash keys from this value in future,
+ normalise it now. */
+ key_p = (char*)bytes_from_utf8((const U8*)key_p, &key_len, &is_utf8);
+ flags |= is_utf8 ? HVhek_UTF8 : HVhek_WASUTF8;
+ }
+
+ return refcounted_he_new_common(parent, key_p, key_len, flags, value_type,
+ ((value_type == HVrhek_PV
+ || value_type == HVrhek_PV_UTF8) ?
+ (void *)value_p : (void *)value),
+ value_len);
+}
+
+struct refcounted_he *
+S_refcounted_he_new_common(pTHX_ struct refcounted_he *const parent,
+ const char *const key_p, const STRLEN key_len,
+ const char flags, char value_type,
+ const void *value, const STRLEN value_len) {
+ dVAR;
+ struct refcounted_he *he;
+ U32 hash;
+ const bool is_pv = value_type == HVrhek_PV || value_type == HVrhek_PV_UTF8;
+ STRLEN key_offset = is_pv ? value_len + 2 : 1;
+
+ PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_COMMON;
#ifdef USE_ITHREADS
he = (struct refcounted_he*)
+ key_offset);
#endif
-
he->refcounted_he_next = parent;
- if (value_type == HVrhek_PV) {
- Copy(value_p, he->refcounted_he_data + 1, value_len + 1, char);
+ if (is_pv) {
+ Copy((char *)value, he->refcounted_he_data + 1, value_len + 1, char);
he->refcounted_he_val.refcounted_he_u_len = value_len;
- /* Do it this way so that the SvUTF8() test is after the SvPV, in case
- the value is overloaded, and doesn't yet have the UTF-8flag set. */
- if (SvUTF8(value))
- value_type = HVrhek_PV_UTF8;
} else if (value_type == HVrhek_IV) {
- if (SvUOK(value)) {
- he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
- value_type = HVrhek_UV;
- } else {
- he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
- }
+ he->refcounted_he_val.refcounted_he_u_iv = SvIVX(value);
+ } else if (value_type == HVrhek_UV) {
+ he->refcounted_he_val.refcounted_he_u_uv = SvUVX(value);
}
- flags = value_type;
- if (is_utf8) {
- /* Hash keys are always stored normalised to (yes) ISO-8859-1.
- As we're going to be building hash keys from this value in future,
- normalise it now. */
- key_p = (char*)bytes_from_utf8((const U8*)key_p, &key_len, &is_utf8);
- flags |= is_utf8 ? HVhek_UTF8 : HVhek_WASUTF8;
- }
PERL_HASH(hash, key_p, key_len);
#ifdef USE_ITHREADS
if (*HEK_KEY(chain->refcounted_he_hek) != ':')
return NULL;
#endif
+ /* Stop anyone trying to really mess us up by adding their own value for
+ ':' into %^H */
+ if ((chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV
+ && (chain->refcounted_he_data[0] & HVrhek_typemask) != HVrhek_PV_UTF8)
+ return NULL;
+
if (len)
*len = chain->refcounted_he_val.refcounted_he_u_len;
if (flags) {
return chain->refcounted_he_data + 1;
}
+/* As newSTATEOP currently gets passed plain char* labels, we will only provide
+ that interface. Once it works out how to pass in length and UTF-8 ness, this
+ function will need superseding. */
+struct refcounted_he *
+Perl_store_cop_label(pTHX_ struct refcounted_he *const chain, const char *label)
+{
+ return refcounted_he_new_common(chain, ":", 1, HVrhek_PV, HVrhek_PV,
+ label, strlen(label));
+}
+
/*
=for apidoc hv_assert
HINTS_REFCNT_UNLOCK;
}
if (label) {
- /* Proof of concept for now - for efficiency reasons these are likely
- to end up being replaced by a custom function in hv.c */
- SV *const key = newSVpvs(":");
- SV *const value = newSVpv(label, 0);
cop->cop_hints_hash
- = Perl_refcounted_he_new(aTHX_ cop->cop_hints_hash, key, value);
+ = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
PL_hints |= HINT_BLOCK_SCOPE;
/* It seems that we need to defer freeing this pointer, as other parts
of the grammar end up wanting to copy it after this op has been
created. */
SAVEFREEPV(label);
- SvREFCNT_dec(key);
- SvREFCNT_dec(value);
}
if (PL_parser && PL_parser->copline == NOLINE)
These tasks would need C knowledge, and knowledge of how the interpreter works,
or a willingness to learn.
-=head2 Abolish cop_label?
-
-C<struct cop> contains
-
- char * cop_label; /* label for this construct */
-
-Most statements don't have labels. It might be possible to eliminate this
-member and instead store the label, if present, in
-
- struct refcounted_he * cop_hints_hash;
-
-(with a hint bit, similar to
-
- #define HINT_ARYBASE 0x00000010 /* $[ is non-zero */
- #define HINT_LEXICAL_IO_IN 0x00040000 /* ${^OPEN} is set for input */
- #define HINT_LEXICAL_IO_OUT 0x00080000 /* ${^OPEN} is set for output */
-
-). The trick would be ensuring that this faked lexical hint doesn't get
-propagated to nested scopes. It might be as simple as moving the setting of
-"cop_label" in C<Perl_newSTATEOP> after the code to set up
-C<cop->cop_hints_hash>.
-
=head2 lexicals used only once
This warns:
PERL_CALLCONV SV * Perl_refcounted_he_fetch(pTHX_ const struct refcounted_he *chain, SV *keysv, const char *key, STRLEN klen, int flags, U32 hash);
PERL_CALLCONV void Perl_refcounted_he_free(pTHX_ struct refcounted_he *he);
PERL_CALLCONV struct refcounted_he * Perl_refcounted_he_new(pTHX_ struct refcounted_he *const parent, SV *const key, SV *const value);
+#if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT)
+STATIC struct refcounted_he * S_refcounted_he_new_common(pTHX_ struct refcounted_he *const parent, const char *const key_p, const STRLEN key_len, const char flags, char value_type, const void *value, const STRLEN value_len)
+ __attribute__nonnull__(pTHX_2)
+ __attribute__nonnull__(pTHX_6);
+#define PERL_ARGS_ASSERT_REFCOUNTED_HE_NEW_COMMON \
+ assert(key_p); assert(value)
+
+#endif
/* PERL_CALLCONV SV** Perl_hv_store(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash); */
/* PERL_CALLCONV HE* Perl_hv_store_ent(pTHX_ HV *hv, SV *key, SV *val, U32 hash); */
/* PERL_CALLCONV SV** Perl_hv_store_flags(pTHX_ HV *hv, const char *key, I32 klen, SV *val, U32 hash, int flags); */
PERL_CALLCONV void Perl_sys_term(void);
PERL_CALLCONV const char * Perl_fetch_cop_label(pTHX_ struct refcounted_he *const chain, STRLEN *len, U32 *flags);
+PERL_CALLCONV struct refcounted_he * Perl_store_cop_label(pTHX_ struct refcounted_he *const chain, const char *label)
+ __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_STORE_COP_LABEL \
+ assert(label)
+
END_EXTERN_C
/*
projects / p5sagit/p5-mst-13.2.git / commitdiff