#include "perl.h"
#include "XSUB.h"
#ifdef HAS_PPPORT_H
+# define NEED_sv_2pv_flags
# define NEED_vnewSVpvf
# define NEED_warner
+# define NEED_newSVpvn_flags
# include "ppport.h"
# include "shared.h"
#endif
#ifdef USE_ITHREADS
+/* Magic signature(s) for mg_private to make PERL_MAGIC_ext magic safer */
+#define UL_MAGIC_SIG 0x554C /* UL = user lock */
+
/*
* The shared things need an intepreter to live in ...
*/
/* XXX Redesign the storage of user locks so we don't need a global
* lock to access them ???? DAPM */
ENTER_LOCK;
- mg = mg_find(ssv, PERL_MAGIC_ext);
+
+ /* Version of mg_find that also checks the private signature */
+ for (mg = SvMAGIC(ssv); mg; mg = mg->mg_moremagic) {
+ if ((mg->mg_type == PERL_MAGIC_ext) &&
+ (mg->mg_private == UL_MAGIC_SIG))
+ {
+ break;
+ }
+ }
+
if (mg) {
ul = (user_lock*)(mg->mg_ptr);
} else if (create) {
ul = (user_lock *) PerlMemShared_malloc(sizeof(user_lock));
Zero(ul, 1, user_lock);
/* Attach to shared SV using ext magic */
- sv_magicext(ssv, NULL, PERL_MAGIC_ext, &sharedsv_userlock_vtbl,
- (char *)ul, 0);
+ mg = sv_magicext(ssv, NULL, PERL_MAGIC_ext, &sharedsv_userlock_vtbl,
+ (char *)ul, 0);
+ mg->mg_private = UL_MAGIC_SIG; /* Set private signature */
recursive_lock_init(aTHX_ &ul->lock);
COND_INIT(&ul->user_cond);
CALLER_CONTEXT;
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;
PROTOTYPES: ENABLE
void
-_id(SV *ref)
+_id(SV *myref)
PROTOTYPE: \[$@%]
PREINIT:
SV *ssv;
CODE:
- ref = SvRV(ref);
- if (SvROK(ref))
- ref = SvRV(ref);
- ssv = Perl_sharedsv_find(aTHX_ ref);
+ myref = SvRV(myref);
+ if (SvMAGICAL(myref))
+ mg_get(myref);
+ if (SvROK(myref))
+ myref = SvRV(myref);
+ ssv = Perl_sharedsv_find(aTHX_ myref);
if (! ssv)
XSRETURN_UNDEF;
ST(0) = sv_2mortal(newSVuv(PTR2UV(ssv)));
void
-_refcnt(SV *ref)
+_refcnt(SV *myref)
PROTOTYPE: \[$@%]
PREINIT:
SV *ssv;
CODE:
- ref = SvRV(ref);
- if (SvROK(ref))
- ref = SvRV(ref);
- ssv = Perl_sharedsv_find(aTHX_ ref);
+ myref = SvRV(myref);
+ if (SvROK(myref))
+ myref = SvRV(myref);
+ ssv = Perl_sharedsv_find(aTHX_ myref);
if (! ssv) {
- Perl_warn(aTHX_ "%" SVf " is not shared", ST(0));
+ if (ckWARN(WARN_THREADS)) {
+ Perl_warner(aTHX_ packWARN(WARN_THREADS),
+ "%" SVf " is not shared", ST(0));
+ }
XSRETURN_UNDEF;
}
ST(0) = sv_2mortal(newSViv(SvREFCNT(ssv)));
void
-share(SV *ref)
+share(SV *myref)
PROTOTYPE: \[$@%]
CODE:
- if (! SvROK(ref))
+ if (! SvROK(myref))
Perl_croak(aTHX_ "Argument to share needs to be passed as ref");
- ref = SvRV(ref);
- if (SvROK(ref))
- ref = SvRV(ref);
- Perl_sharedsv_share(aTHX_ ref);
- ST(0) = sv_2mortal(newRV_inc(ref));
+ myref = SvRV(myref);
+ if (SvROK(myref))
+ myref = SvRV(myref);
+ Perl_sharedsv_share(aTHX_ myref);
+ ST(0) = sv_2mortal(newRV_inc(myref));
/* XSRETURN(1); - implied */
void
-cond_signal(SV *ref)
+cond_signal(SV *myref)
PROTOTYPE: \[$@%]
PREINIT:
SV *ssv;
user_lock *ul;
CODE:
- if (! SvROK(ref))
+ if (! SvROK(myref))
Perl_croak(aTHX_ "Argument to cond_signal needs to be passed as ref");
- ref = SvRV(ref);
- if (SvROK(ref))
- ref = SvRV(ref);
- ssv = Perl_sharedsv_find(aTHX_ ref);
+ myref = SvRV(myref);
+ if (SvROK(myref))
+ myref = SvRV(myref);
+ ssv = Perl_sharedsv_find(aTHX_ myref);
if (! ssv)
Perl_croak(aTHX_ "cond_signal can only be used on shared values");
ul = S_get_userlock(aTHX_ ssv, 1);
void
-cond_broadcast(SV *ref)
+cond_broadcast(SV *myref)
PROTOTYPE: \[$@%]
PREINIT:
SV *ssv;
user_lock *ul;
CODE:
- if (! SvROK(ref))
+ if (! SvROK(myref))
Perl_croak(aTHX_ "Argument to cond_broadcast needs to be passed as ref");
- ref = SvRV(ref);
- if (SvROK(ref))
- ref = SvRV(ref);
- ssv = Perl_sharedsv_find(aTHX_ ref);
+ myref = SvRV(myref);
+ if (SvROK(myref))
+ myref = SvRV(myref);
+ ssv = Perl_sharedsv_find(aTHX_ myref);
if (! ssv)
Perl_croak(aTHX_ "cond_broadcast can only be used on shared values");
ul = S_get_userlock(aTHX_ ssv, 1);
void
-bless(SV* ref, ...);
+bless(SV* myref, ...);
PROTOTYPE: $;$
PREINIT:
HV* stash;
}
stash = gv_stashpvn(ptr, len, TRUE);
}
- SvREFCNT_inc_void(ref);
- (void)sv_bless(ref, stash);
- ST(0) = sv_2mortal(ref);
- ssv = Perl_sharedsv_find(aTHX_ ref);
+ SvREFCNT_inc_void(myref);
+ (void)sv_bless(myref, stash);
+ ST(0) = sv_2mortal(myref);
+ ssv = Perl_sharedsv_find(aTHX_ myref);
if (ssv) {
dTHXc;
ENTER_LOCK;
projects / p5sagit/p5-mst-13.2.git / blobdiff