#endif
else if (v == &PL_vtbl_amagic) s = "amagic";
else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
+ else if (v == &PL_vtbl_backref) s = "backref";
if (s)
dump_indent(level, file, " MG_VIRTUAL = &PL_vtbl_%s\n", s);
else
if (flags & SVf_IOK) sv_catpv(d, "IOK,");
if (flags & SVf_NOK) sv_catpv(d, "NOK,");
if (flags & SVf_POK) sv_catpv(d, "POK,");
- if (flags & SVf_ROK) sv_catpv(d, "ROK,");
+ if (flags & SVf_ROK) {
+ sv_catpv(d, "ROK,");
+ if (SvWEAKREF(sv)) sv_catpv(d, "WEAKREF,");
+ }
if (flags & SVf_OOK) sv_catpv(d, "OOK,");
if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
#define magic_gettaint Perl_magic_gettaint
#define magic_getuvar Perl_magic_getuvar
#define magic_getvec Perl_magic_getvec
+#define magic_killbackrefs Perl_magic_killbackrefs
#define magic_len Perl_magic_len
#define magic_mutexfree Perl_magic_mutexfree
#define magic_nextpack Perl_magic_nextpack
#define sv_replace Perl_sv_replace
#define sv_report_used Perl_sv_report_used
#define sv_reset Perl_sv_reset
+#define sv_rvweaken Perl_sv_rvweaken
#define sv_setiv Perl_sv_setiv
#define sv_setiv_mg Perl_sv_setiv_mg
#define sv_setnv Perl_sv_setnv
#define magic_gettaint CPerlObj::Perl_magic_gettaint
#define magic_getuvar CPerlObj::Perl_magic_getuvar
#define magic_getvec CPerlObj::Perl_magic_getvec
+#define magic_killbackrefs CPerlObj::Perl_magic_killbackrefs
#define magic_len CPerlObj::Perl_magic_len
#define magic_methcall CPerlObj::Perl_magic_methcall
#define magic_methcall CPerlObj::Perl_magic_methcall
#define sv_2pv_nolen CPerlObj::Perl_sv_2pv_nolen
#define sv_2uv CPerlObj::Perl_sv_2uv
#define sv_add_arena CPerlObj::Perl_sv_add_arena
+#define sv_add_backref CPerlObj::Perl_sv_add_backref
#define sv_backoff CPerlObj::Perl_sv_backoff
#define sv_bless CPerlObj::Perl_sv_bless
#define sv_catpv CPerlObj::Perl_sv_catpv
#define sv_collxfrm CPerlObj::Perl_sv_collxfrm
#define sv_compile_2op CPerlObj::Perl_sv_compile_2op
#define sv_dec CPerlObj::Perl_sv_dec
+#define sv_del_backref CPerlObj::Perl_sv_del_backref
#define sv_derived_from CPerlObj::Perl_sv_derived_from
#define sv_dump CPerlObj::Perl_sv_dump
#define sv_eq CPerlObj::Perl_sv_eq
#define sv_replace CPerlObj::Perl_sv_replace
#define sv_report_used CPerlObj::Perl_sv_report_used
#define sv_reset CPerlObj::Perl_sv_reset
+#define sv_rvweaken CPerlObj::Perl_sv_rvweaken
#define sv_setiv CPerlObj::Perl_sv_setiv
#define sv_setiv_mg CPerlObj::Perl_sv_setiv_mg
#define sv_setnv CPerlObj::Perl_sv_setnv
new_logop
simplify_sort
is_handle_constructor
+ sv_add_backref
+ sv_del_backref
do_trans_CC_simple
do_trans_CC_count
do_trans_CC_complex
magic_gettaint
magic_getuvar
magic_getvec
+magic_killbackrefs
magic_len
magic_mutexfree
magic_nextpack
sv_replace
sv_report_used
sv_reset
+sv_rvweaken
sv_setiv
sv_setiv_mg
sv_setnv
}
int
+magic_killbackrefs(SV *sv, MAGIC *mg)
+{
+ AV *av = (AV*)mg->mg_obj;
+ SV **svp = AvARRAY(av);
+ I32 i = AvFILLp(av);
+ while (i >= 0) {
+ if (svp[i] && svp[i] != &PL_sv_undef) {
+ if (!SvWEAKREF(svp[i]))
+ croak("panic: magic_killbackrefs");
+ /* XXX Should we check that it hasn't changed? */
+ SvRV(svp[i]) = 0;
+ SvOK_off(svp[i]);
+ SvWEAKREF_off(svp[i]);
+ svp[i] = &PL_sv_undef;
+ }
+ i--;
+ }
+ return 0;
+}
+
+int
magic_setmglob(SV *sv, MAGIC *mg)
{
mg->mg_len = -1;
#define magic_getuvar pPerl->Perl_magic_getuvar
#undef magic_getvec
#define magic_getvec pPerl->Perl_magic_getvec
+#undef magic_killbackrefs
+#define magic_killbackrefs pPerl->Perl_magic_killbackrefs
#undef magic_len
#define magic_len pPerl->Perl_magic_len
#undef magic_methcall
#define sv_2uv pPerl->Perl_sv_2uv
#undef sv_add_arena
#define sv_add_arena pPerl->Perl_sv_add_arena
+#undef sv_add_backref
+#define sv_add_backref pPerl->Perl_sv_add_backref
#undef sv_backoff
#define sv_backoff pPerl->Perl_sv_backoff
#undef sv_bless
#define sv_compile_2op pPerl->Perl_sv_compile_2op
#undef sv_dec
#define sv_dec pPerl->Perl_sv_dec
+#undef sv_del_backref
+#define sv_del_backref pPerl->Perl_sv_del_backref
#undef sv_derived_from
#define sv_derived_from pPerl->Perl_sv_derived_from
#undef sv_dump
#define sv_report_used pPerl->Perl_sv_report_used
#undef sv_reset
#define sv_reset pPerl->Perl_sv_reset
+#undef sv_rvweaken
+#define sv_rvweaken pPerl->Perl_sv_rvweaken
#undef sv_setiv
#define sv_setiv pPerl->Perl_sv_setiv
#undef sv_setiv_mg
want_vtbl_mutex,
#endif
want_vtbl_regdata,
- want_vtbl_regdatum
+ want_vtbl_regdatum,
+ want_vtbl_backref
};
/* Note: the lowest 8 bits are reserved for
EXT MGVTBL PL_vtbl_amagicelem = {0, magic_setamagic,
0, 0, magic_setamagic};
+EXT MGVTBL PL_vtbl_backref = {0, 0,
+ 0, 0, magic_killbackrefs};
+
#else /* !DOINIT */
EXT MGVTBL PL_vtbl_sv;
EXT MGVTBL PL_vtbl_amagic;
EXT MGVTBL PL_vtbl_amagicelem;
+EXT MGVTBL PL_vtbl_backref;
+
#endif /* !DOINIT */
enum {
subscript. But to the left of the brackets was an expression that
didn't look like an array reference, or anything else subscriptable.
+=item Can't weaken a nonreference
+
+(F) You attempted to weaken something that was not a reference. Only
+references can be weakened.
+
=item Can't x= to read-only value
(F) You tried to repeat a constant value (often the undefined value) with
(P) The savestack was requested to restore more localized values than there
are in the savestack.
+=item panic: del_backref
+
+(P) Failed an internal consistency check while trying to reset a weak
+reference.
+
=item panic: die %s
(P) We popped the context stack to an eval context, and then discovered
(P) Something requested a negative number of bytes of malloc.
+=item panic: magic_killbackrefs
+
+(P) Failed an internal consistency check while trying to reset all weak
+references to an object.
+
=item panic: mapstart
(P) The compiler is screwed up with respect to the map() function.
%hash = ( one => 1, two => 2, ); # right
%hash = qw( one 1 two 2 ); # also fine
+=item Reference is already weak
+
+(W) You have attempted to weaken a reference that is already weak.
+Doing so has no effect.
+
=item Reference miscount in sv_replace()
(W) The internal sv_replace() function was handed a new SV with a
OP *new_logop _((I32 type, I32 flags, OP **firstp, OP **otherp));
void simplify_sort _((OP *o));
bool is_handle_constructor _((OP *o, I32 argnum));
+void sv_add_backref _((SV *tsv, SV *sv));
+void sv_del_backref _((SV *sv));
I32 do_trans_CC_simple _((SV *sv));
I32 do_trans_CC_count _((SV *sv));
VIRTUAL void sv_force_normal _((SV *sv));
VIRTUAL void tmps_grow _((I32 n));
+VIRTUAL SV* sv_rvweaken _((SV *));
+VIRTUAL int magic_killbackrefs _((SV *sv, MAGIC *mg));
static void del_xpv _((XPV* p));
static void del_xrv _((XRV* p));
static void sv_unglob _((SV* sv));
+static void sv_add_backref _((SV *tsv, SV *sv));
+static void sv_del_backref _((SV *sv));
#ifndef PURIFY
static void *my_safemalloc(MEM_SIZE size);
case '.':
mg->mg_virtual = &PL_vtbl_pos;
break;
+ case '<':
+ mg->mg_virtual = &PL_vtbl_backref;
+ break;
case '~': /* Reserved for use by extensions not perl internals. */
/* Useful for attaching extension internal data to perl vars. */
/* Note that multiple extensions may clash if magical scalars */
return 0;
}
+SV *
+sv_rvweaken(SV *sv)
+{
+ SV *tsv;
+ if (!SvOK(sv)) /* let undefs pass */
+ return sv;
+ if (!SvROK(sv))
+ croak("Can't weaken a nonreference");
+ else if (SvWEAKREF(sv)) {
+ dTHR;
+ if (ckWARN(WARN_MISC))
+ warner(WARN_MISC, "Reference is already weak");
+ return sv;
+ }
+ tsv = SvRV(sv);
+ sv_add_backref(tsv, sv);
+ SvWEAKREF_on(sv);
+ SvREFCNT_dec(tsv);
+ return sv;
+}
+
+STATIC void
+sv_add_backref(SV *tsv, SV *sv)
+{
+ AV *av;
+ MAGIC *mg;
+ if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
+ av = (AV*)mg->mg_obj;
+ else {
+ av = newAV();
+ sv_magic(tsv, (SV*)av, '<', NULL, 0);
+ SvREFCNT_dec(av); /* for sv_magic */
+ }
+ av_push(av,sv);
+}
+
+STATIC void
+sv_del_backref(SV *sv)
+{
+ AV *av;
+ SV **svp;
+ I32 i;
+ SV *tsv = SvRV(sv);
+ MAGIC *mg;
+ if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
+ croak("panic: del_backref");
+ av = (AV *)mg->mg_obj;
+ svp = AvARRAY(av);
+ i = AvFILLp(av);
+ while (i >= 0) {
+ if (svp[i] == sv) {
+ svp[i] = &PL_sv_undef; /* XXX */
+ }
+ i--;
+ }
+}
+
void
sv_insert(SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
{
/* FALL THROUGH */
case SVt_PV:
case SVt_RV:
- if (SvROK(sv))
- SvREFCNT_dec(SvRV(sv));
+ if (SvROK(sv)) {
+ if (SvWEAKREF(sv))
+ sv_del_backref(sv);
+ else
+ SvREFCNT_dec(SvRV(sv));
+ }
else if (SvPVX(sv) && SvLEN(sv))
Safefree(SvPVX(sv));
break;
sv_unref(SV *sv)
{
SV* rv = SvRV(sv);
-
+
+ if (SvWEAKREF(sv)) {
+ sv_del_backref(sv);
+ SvWEAKREF_off(sv);
+ SvRV(sv) = 0;
+ return;
+ }
SvRV(sv) = 0;
SvROK_off(sv);
if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
#define SVphv_SHAREKEYS 0x20000000 /* keys live on shared string table */
#define SVphv_LAZYDEL 0x40000000 /* entry in xhv_eiter must be deleted */
+#define SVprv_WEAKREF 0x80000000 /* Weak reference */
+
struct xrv {
SV * xrv_rv; /* pointer to another SV */
};
*/
#define Gv_AMG(stash) (PL_amagic_generation && Gv_AMupdate(stash))
+#define SvWEAKREF(sv) ((SvFLAGS(sv) & (SVf_ROK|SVprv_WEAKREF)) \
+ == (SVf_ROK|SVprv_WEAKREF))
+#define SvWEAKREF_on(sv) (SvFLAGS(sv) |= (SVf_ROK|SVprv_WEAKREF))
+#define SvWEAKREF_off(sv) (SvFLAGS(sv) &= ~(SVf_ROK|SVprv_WEAKREF))
+
#define SvTHINKFIRST(sv) (SvFLAGS(sv) & SVf_THINKFIRST)
#define SvPADBUSY(sv) (SvFLAGS(sv) & SVs_PADBUSY)
case want_vtbl_amagicelem:
result = &PL_vtbl_amagicelem;
break;
+ case want_vtbl_backref:
+ result = &PL_vtbl_backref;
+ break;
}
return result;
}
projects / p5sagit/p5-mst-13.2.git / commitdiff