# define NEED_sv_2pv_flags
# define NEED_vnewSVpvf
# define NEED_warner
+# define NEED_newSVpvn_flags
# include "ppport.h"
# include "shared.h"
#endif
ENTER_LOCK;
if (SvROK(ssv)) {
S_get_RV(aTHX_ sv, ssv);
+ /* Look ahead for refs of refs */
+ if (SvROK(SvRV(ssv))) {
+ SvROK_on(SvRV(sv));
+ S_get_RV(aTHX_ SvRV(sv), SvRV(ssv));
+ }
} else {
sv_setsv_nomg(sv, ssv);
}
svp = av_fetch((AV*) saggregate, mg->mg_len, 0);
} else {
char *key = mg->mg_ptr;
- STRLEN len = mg->mg_len;
+ I32 len = mg->mg_len;
assert ( mg->mg_ptr != 0 );
if (mg->mg_len == HEf_SVKEY) {
- key = SvPV((SV *) mg->mg_ptr, len);
+ STRLEN slen;
+ key = SvPV((SV *)mg->mg_ptr, slen);
+ len = slen;
+ if (SvUTF8((SV *)mg->mg_ptr)) {
+ len = -len;
+ }
}
SHARED_CONTEXT;
svp = hv_fetch((HV*) saggregate, key, len, 0);
/* Exists in the array */
if (SvROK(*svp)) {
S_get_RV(aTHX_ sv, *svp);
+ /* Look ahead for refs of refs */
+ if (SvROK(SvRV(*svp))) {
+ SvROK_on(SvRV(sv));
+ S_get_RV(aTHX_ SvRV(sv), SvRV(*svp));
+ }
} else {
- /* XXX Can this branch ever happen? DAPM */
- /* XXX assert("no such branch"); */
+ /* $ary->[elem] or $ary->{elem} is a scalar */
Perl_sharedsv_associate(aTHX_ sv, *svp);
sv_setsv(sv, *svp);
}
svp = av_fetch((AV*) saggregate, mg->mg_len, 1);
} else {
char *key = mg->mg_ptr;
- STRLEN len = mg->mg_len;
+ I32 len = mg->mg_len;
assert ( mg->mg_ptr != 0 );
- if (mg->mg_len == HEf_SVKEY)
- key = SvPV((SV *) mg->mg_ptr, len);
+ if (mg->mg_len == HEf_SVKEY) {
+ STRLEN slen;
+ key = SvPV((SV *)mg->mg_ptr, slen);
+ len = slen;
+ if (SvUTF8((SV *)mg->mg_ptr)) {
+ len = -len;
+ }
+ }
SHARED_CONTEXT;
svp = hv_fetch((HV*) saggregate, key, len, 1);
}
av_delete((AV*) saggregate, mg->mg_len, G_DISCARD);
} else {
char *key = mg->mg_ptr;
- STRLEN len = mg->mg_len;
+ I32 len = mg->mg_len;
assert ( mg->mg_ptr != 0 );
- if (mg->mg_len == HEf_SVKEY)
- key = SvPV((SV *) mg->mg_ptr, len);
+ if (mg->mg_len == HEf_SVKEY) {
+ STRLEN slen;
+ key = SvPV((SV *)mg->mg_ptr, slen);
+ len = slen;
+ if (SvUTF8((SV *)mg->mg_ptr)) {
+ len = -len;
+ }
+ }
SHARED_CONTEXT;
hv_delete((HV*) saggregate, key, len, G_DISCARD);
}
* This is called when perl is about to access an element of
* the array -
*/
+#if PERL_VERSION >= 11
+int
+sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
+ SV *nsv, const char *name, I32 namlen)
+#else
int
sharedsv_array_mg_copy(pTHX_ SV *sv, MAGIC* mg,
SV *nsv, const char *name, int namlen)
+#endif
{
MAGIC *nmg = sv_magicext(nsv,mg->mg_obj,
toLOWER(mg->mg_type),&sharedsv_elem_vtbl,
}
+/* Can a shared object be destroyed?
+ * True if not a shared,
+ * or if detroying last proxy on a shared object
+ */
+#ifdef PL_destroyhook
+bool
+Perl_shared_object_destroy(pTHX_ SV *sv)
+{
+ SV *ssv;
+
+ if (SvROK(sv))
+ sv = SvRV(sv);
+ ssv = Perl_sharedsv_find(aTHX_ sv);
+ return (!ssv || (SvREFCNT(ssv) <= 1));
+}
+#endif
+
+
/* Saves a space for keeping SVs wider than an interpreter. */
void
recursive_lock_init(aTHX_ &PL_sharedsv_lock);
PL_lockhook = &Perl_sharedsv_locksv;
PL_sharehook = &Perl_sharedsv_share;
+#ifdef PL_destroyhook
+ PL_destroyhook = &Perl_shared_object_destroy;
+#endif
}
#endif /* USE_ITHREADS */
SHARED_EDIT;
exists = av_exists((AV*) sobj, SvIV(index));
} else {
- STRLEN len;
- char *key = SvPV(index,len);
+ I32 len;
+ STRLEN slen;
+ char *key = SvPVutf8(index, slen);
+ len = slen;
+ if (SvUTF8(index)) {
+ len = -len;
+ }
SHARED_EDIT;
exists = hv_exists((HV*) sobj, key, len);
}
hv_iterinit((HV*) sobj);
entry = hv_iternext((HV*) sobj);
if (entry) {
+ I32 utf8 = HeKUTF8(entry);
key = hv_iterkey(entry,&len);
CALLER_CONTEXT;
- ST(0) = sv_2mortal(newSVpv(key, len));
+ ST(0) = sv_2mortal(newSVpvn_utf8(key, len, utf8));
} else {
CALLER_CONTEXT;
ST(0) = &PL_sv_undef;
SHARED_CONTEXT;
entry = hv_iternext((HV*) sobj);
if (entry) {
+ I32 utf8 = HeKUTF8(entry);
key = hv_iterkey(entry,&len);
CALLER_CONTEXT;
- ST(0) = sv_2mortal(newSVpv(key, len));
+ ST(0) = sv_2mortal(newSVpvn_utf8(key, len, utf8));
} else {
CALLER_CONTEXT;
ST(0) = &PL_sv_undef;
SV *ssv;
CODE:
myref = SvRV(myref);
+ if (SvMAGICAL(myref))
+ mg_get(myref);
if (SvROK(myref))
myref = SvRV(myref);
ssv = Perl_sharedsv_find(aTHX_ myref);