This adds an additional property to magic: prechange magic, which is deleted
before modification (possibly triggering a deletion callback).  Such a 
deletion should not have any side-effects on behaviour of SV, it 
may be used for bookkeeping purposes only (for backward compatibility).

There is no explicit way to call this magic.  Before modification of sv is 
performed, one should check SvREADONLY(sv), which will automatically trigger
the prechange magic - if present.  (Since triggering this magic is 
transparent, there should be no problem with change of semantic of 
SvREADONLY().)

There is a way to check that SV is not modifiable without triggering the
magic, it is called SvREADONLY_TEST(sv).  I did not find a place in
perl code which requires this macro, though.

The macro SvIMMUTABLE(sv) may be used to check that the fields of SV
may be changed directly.  If not, they may be changed via Perl API
only (triggering prechange magic), or the SV is SvREADONLY_TEST(sv).

In perl code SvREADONLY_on()/off() are not used on SVs which may have
RMAGICAL flag, so the existing macros are safe.



--- ./mg.h~	Tue Nov 25 09:52:56 1997
+++ ./mg.h	Tue Mar 17 18:34:36 1998
@@ -29,8 +29,10 @@ struct magic {
 #define MGf_TAINTEDDIR 1
 #define MGf_REFCOUNTED 2
 #define MGf_GSKIP      4
+#define MGf_PRE_CHANGE 8
 
 #define MGf_MINMATCH   1
+#define MGf_NOT_RO     1		/* The SV was not READONLY. */
 
 #define MgTAINTEDDIR(mg)	(mg->mg_flags & MGf_TAINTEDDIR)
 #define MgTAINTEDDIR_on(mg)	(mg->mg_flags |= MGf_TAINTEDDIR)
--- ./global.sym.orig	Mon Jun  8 21:01:54 1998
+++ ./global.sym	Tue Jun  9 00:00:36 1998
@@ -389,6 +389,7 @@ magic_clearsig
 magic_existspack
 magic_freedefelem
 magic_freeregexp
+magic_freesoftlink
 magic_get
 magic_getarylen
 magic_getdefelem
@@ -401,6 +402,7 @@ magic_getsubstr
 magic_gettaint
 magic_getuvar
 magic_getvec
+magic_killsoftlinks
 magic_len
 magic_mutexfree
 magic_nextpack
@@ -421,6 +423,7 @@ magic_setnkeys
 magic_setpack
 magic_setpos
 magic_setsig
+magic_setsoftlink
 magic_setsubstr
 magic_settaint
 magic_setuvar
@@ -983,6 +986,7 @@ sv_2uv
 sv_add_arena
 sv_backoff
 sv_bless
+sv_cannot_modify
 sv_catpv
 sv_catpv_mg
 sv_catpvf
@@ -1025,7 +1029,9 @@ sv_ref
 sv_reftype
 sv_replace
 sv_report_used
+sv_request_modify
 sv_reset
+sv_rvsoft
 sv_setiv
 sv_setiv_mg
 sv_setnv
--- ./mg.c.orig	Mon Mar 16 06:41:48 1998
+++ ./mg.c	Tue Mar 17 19:02:48 1998
@@ -1333,6 +1333,74 @@ vivify_defelem(SV *sv)
     mg->mg_flags &= ~MGf_REFCOUNTED;
 }
 
+static int
+magic_change_softlink(sv,mg,kill)
+SV* sv;
+MAGIC* mg;
+I32 kill;
+{
+    SV *target = mg->mg_obj;
+    MAGIC *tmg = mg_find(target, '<');
+    AV *av = (AV*)tmg->mg_obj;
+    SV **svp = AvARRAY(av);
+    I32 i = AvFILL(av);
+
+    while (i >= 0) {
+	if (svp[i] != sv) {
+	    i--;
+	    continue;
+	}
+	svp[i] = svp[AvFILLp(av)--];
+#if 0					/* A cycle may be longer... */
+	if (AvFILL(av) == -1 && target != sv) /* It is dangerous to unmagic */
+	    sv_unmagic(target, '<');
+#endif
+	mg->mg_obj = NULL;		/* Avoid a loop in next unmagic: */
+	mg->mg_flags &= ~MGf_REFCOUNTED;
+	if (!kill)
+	    sv_unmagic(sv, '>');
+	return 0;
+    }
+    croak("panic: backlink softref_dec");
+    return 0;
+}
+
+int
+magic_freesoftlink(sv,mg)
+SV* sv;
+MAGIC* mg;
+{
+    SvROK_off(sv);			/* The refcount is long ago decr'd. */
+    if (mg->mg_flags & MGf_NOT_RO)
+	SvREADONLY_off(sv);
+    if (mg->mg_obj)			/* Are not called in a loop */
+	return magic_change_softlink(sv,mg,1);
+}
+
+int
+magic_setsoftlink(sv,mg)
+SV* sv;
+MAGIC* mg;
+{
+    return magic_change_softlink(sv,mg,0);
+}
+
+int
+magic_killsoftlinks(sv,mg)
+SV* sv;
+MAGIC* mg;
+{
+    AV *av = (AV*)mg->mg_obj;
+    SV **svp = AvARRAY(av);
+    I32 i = AvFILL(av);
+
+    while (i >= 0) {
+	sv_unmagic(svp[i], '>');	/* Calls mg_free */
+	i--;
+    }
+    return 0;
+}
+
 int
 magic_setmglob(SV *sv, MAGIC *mg)
 {
--- ./perl.h.orig	Mon Mar 16 06:31:22 1998
+++ ./perl.h	Tue Mar 17 18:31:48 1998
@@ -1834,6 +1834,11 @@ EXT MGVTBL vtbl_amagicelem =   {0,     m
                                         0,      0,      magic_setamagic};
 #endif /* OVERLOAD */
 
+EXT MGVTBL vtbl_softlink =   {0,     magic_setsoftlink,
+                                        0,      0,      magic_freesoftlink};
+EXT MGVTBL vtbl_softtarget =   {0,     0,
+                                        0,      0,      magic_killsoftlinks};
+
 #else /* !DOINIT */
 
 EXT MGVTBL vtbl_sv;
@@ -1857,6 +1862,8 @@ EXT MGVTBL vtbl_pos;
 EXT MGVTBL vtbl_bm;
 EXT MGVTBL vtbl_fm;
 EXT MGVTBL vtbl_uvar;
+EXT MGVTBL vtbl_softlink;
+EXT MGVTBL vtbl_softtarget;
 
 #ifdef USE_THREADS
 EXT MGVTBL vtbl_mutex;
--- ./proto.h.orig	Mon Jun  8 21:03:16 1998
+++ ./proto.h	Tue Jun  9 00:02:08 1998
@@ -226,6 +226,7 @@ VIRTUAL int	magic_clearsig	_((SV* sv, MA
 VIRTUAL int	magic_existspack _((SV* sv, MAGIC* mg));
 VIRTUAL int	magic_freedefelem _((SV* sv, MAGIC* mg));
 VIRTUAL int	magic_freeregexp _((SV* sv, MAGIC* mg));
+VIRTUAL int	magic_freesoftlink _((SV* sv, MAGIC* mg));
 VIRTUAL int	magic_get	_((SV* sv, MAGIC* mg));
 VIRTUAL int	magic_getarylen	_((SV* sv, MAGIC* mg));
 VIRTUAL int	magic_getdefelem _((SV* sv, MAGIC* mg));
@@ -238,6 +239,7 @@ VIRTUAL int	magic_getsubstr	_((SV* sv, M
 VIRTUAL int	magic_gettaint	_((SV* sv, MAGIC* mg));
 VIRTUAL int	magic_getuvar	_((SV* sv, MAGIC* mg));
 VIRTUAL int	magic_getvec	_((SV* sv, MAGIC* mg));
+VIRTUAL int	magic_killsoftlinks _((SV* sv, MAGIC* mg));
 VIRTUAL U32	magic_len	_((SV* sv, MAGIC* mg));
 #ifdef USE_THREADS
 VIRTUAL int	magic_mutexfree	_((SV* sv, MAGIC* mg));
@@ -263,6 +265,7 @@ VIRTUAL int	magic_setnkeys	_((SV* sv, MA
 VIRTUAL int	magic_setpack	_((SV* sv, MAGIC* mg));
 VIRTUAL int	magic_setpos	_((SV* sv, MAGIC* mg));
 VIRTUAL int	magic_setsig	_((SV* sv, MAGIC* mg));
+VIRTUAL int	magic_setsoftlink _((SV* sv, MAGIC* mg));
 VIRTUAL int	magic_setsubstr	_((SV* sv, MAGIC* mg));
 VIRTUAL int	magic_settaint	_((SV* sv, MAGIC* mg));
 VIRTUAL int	magic_setuvar	_((SV* sv, MAGIC* mg));
@@ -603,6 +606,7 @@ VIRTUAL void	sv_vcatpvfn _((SV* sv, cons
 VIRTUAL void	sv_vsetpvfn _((SV* sv, const char* pat, STRLEN patlen,
 		       va_list* args, SV** svargs, I32 svmax,
 		       bool *used_locale));
+VIRTUAL SV*	sv_rvsoft _((SV* rv));
 VIRTUAL void	taint_env _((void));
 VIRTUAL void	taint_proper _((const char* f, char* s));
 #ifdef UNLINK_ALL_VERSIONS
@@ -672,6 +676,8 @@ void del_xrv _((XRV* p));
 void sv_mortalgrow _((void));
 void sv_unglob _((SV* sv));
 void sv_check_thinkfirst _((SV *sv));
+int sv_cannot_modify _((SV *sv));
+int sv_request_modify _((SV *sv));
 
 SV *newSVpvn _((char *s, STRLEN len));
 
--- ./sv.c.orig	Mon Jun  8 21:01:54 1998
+++ ./sv.c	Mon Jun  8 23:59:14 1998
@@ -645,6 +645,43 @@ my_safemalloc(MEM_SIZE size)
 #define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO))
 #define del_XPVIO(p) my_safefree((char*)p)
 
+/* Should be called with IMMUTABLE and RMAGICAL sv only. */
+int
+sv_request_modify(register SV *sv)
+{
+	/* Check whether SVt_READONLY is set only for PRE_CHANGE
+	   magic, and call this magic if present. */
+	MAGIC *mg = SvMAGIC(sv);
+
+	while (mg) {
+	    MAGIC *next = mg->mg_moremagic;
+
+	    if (mg->mg_flags & MGf_PRE_CHANGE)
+		sv_unmagic(sv, mg->mg_type); /* Trigger _free method. */
+	    mg = next;
+	}
+	return SvIMMUTABLE(sv);		/* Now the real state is restored */
+}
+
+/* Should be called with IMMUTABLE and RMAGICAL sv only. */
+int
+sv_cannot_modify(register SV *sv)
+{
+	/* Check whether SVt_READONLY is set only for PRE_CHANGE magic. */
+	MAGIC *mg = SvMAGIC(sv);
+	int cannot = 1;
+
+	while (mg) {
+	    MAGIC *next = mg->mg_moremagic;
+
+	    if (mg->mg_flags & (MGf_PRE_CHANGE|MGf_NOT_RO) 
+		== (MGf_PRE_CHANGE|MGf_NOT_RO))
+		cannot = 0;
+	    mg = next;
+	}
+	return cannot;			/* Now the real state is restored */
+}
+
 bool
 sv_upgrade(register SV *sv, U32 mt)
 {
@@ -942,7 +979,7 @@ sv_peek(SV *sv)
 	    sv_catpv(t, "SV_UNDEF");
 	    if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
 				 SVs_GMG|SVs_SMG|SVs_RMG)) &&
-		SvREADONLY(sv))
+		SvIMMUTABLE(sv))
 		goto finish;
 	}
 	else if (sv == &sv_no) {
@@ -2596,6 +2633,18 @@ sv_magic(register SV *sv, SV *obj, int h
     case '.':
 	mg->mg_virtual = &vtbl_pos;
 	break;
+    case '>':
+	SvRMAGICAL_on(sv);
+	if (!SvIMMUTABLE(sv)) {
+	    mg->mg_flags |= (MGf_NOT_RO | MGf_PRE_CHANGE);
+	    SvREADONLY_on(sv);
+	} else
+	    mg->mg_flags |= MGf_PRE_CHANGE;
+	mg->mg_virtual = &vtbl_softlink;
+	break;
+    case '<':
+	mg->mg_virtual = &vtbl_softtarget;
+	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	*/
@@ -2644,6 +2693,36 @@ sv_unmagic(SV *sv, int type)
     return 0;
 }
 
+SV*
+sv_rvsoft(sv)
+SV *sv;
+{
+    if (!SvROK(sv))
+	croak("panic: rvsoft: not a reference");
+    if (SvREFCNT(SvRV(sv)) == 1) 
+	sv_setsv(sv, &sv_undef);
+    else {
+	AV *av;
+	SV *tsv = SvRV(sv);
+	MAGIC *mg = mg_find(tsv, '<');
+	
+	if (mg)  {
+	    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);
+	/* When sv is freeed, it will be ROK_off before tsv may be CNT_dec. */
+	sv_magic(sv, tsv, '>', NULL, 0);
+	if (tsv != sv)			/* Quirks of sv_magic... */
+	    SvREFCNT_dec(tsv);		/* for sv_magic */
+	SvREFCNT_dec(tsv);		/* for ROK_off */
+    }
+    return sv;
+}
+
 void
 sv_insert(SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
 {
--- ./av.c~	Thu May 28 13:02:16 1998
+++ ./av.c	Mon Jun  8 23:25:54 1998
@@ -208,7 +208,7 @@ av_store(register AV *av, I32 key, SV *v
 	    return 0;
     }
 
-    if (SvREADONLY(av) && key >= AvFILL(av))
+    if (AvREADONLY(av) && key >= AvFILL(av))
 	croak(no_modify);
 
     if (SvRMAGICAL(av)) {
@@ -384,7 +384,7 @@ av_push(register AV *av, SV *val)
     MAGIC *mg;
     if (!av)
 	return;
-    if (SvREADONLY(av))
+    if (AvREADONLY(av))
 	croak(no_modify);
 
     if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
@@ -412,7 +412,7 @@ av_pop(register AV *av)
 
     if (!av || AvFILL(av) < 0)
 	return &sv_undef;
-    if (SvREADONLY(av))
+    if (AvREADONLY(av))
 	croak(no_modify);
     if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
 	dSP;    
@@ -446,7 +446,7 @@ av_unshift(register AV *av, register I32
 
     if (!av || num <= 0)
 	return;
-    if (SvREADONLY(av))
+    if (AvREADONLY(av))
 	croak(no_modify);
 
     if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
@@ -498,7 +498,7 @@ av_shift(register AV *av)
 
     if (!av || AvFILL(av) < 0)
 	return &sv_undef;
-    if (SvREADONLY(av))
+    if (AvREADONLY(av))
 	croak(no_modify);
     if (SvRMAGICAL(av) && (mg = mg_find((SV*)av,'P'))) {
 	dSP;
--- ./av.h~	Tue Feb  3 08:14:18 1998
+++ ./av.h	Mon Jun  8 23:24:44 1998
@@ -49,3 +49,4 @@ struct xpvav {
 #define AvFILL(av)	((SvRMAGICAL((SV *) (av))) \
 			  ? mg_size((SV *) av) : AvFILLp(av))
 
+#define AvREADONLY SvIMMUTABLE
--- ./doop.c~	Fri May 15 08:58:54 1998
+++ ./doop.c	Mon Jun  8 23:38:38 1998
@@ -32,7 +32,7 @@ do_trans(SV *sv, OP *arg)
     register U8 *p;
     STRLEN len;
 
-    if (SvREADONLY(sv) && !(op->op_private & OPpTRANS_COUNTONLY))
+    if (!(op->op_private & OPpTRANS_COUNTONLY) && SvREADONLY(sv))
 	croak(no_modify);
     tbl = (short*)cPVOP->op_pv;
     s = (U8*)SvPV(sv, len);
--- ./op.c~	Fri May 29 07:00:14 1998
+++ ./op.c	Mon Jun  8 23:41:48 1998
@@ -3354,7 +3354,7 @@ op_const_sv(OP *o, CV *cv)
 	else if (type == OP_PADSV && cv) {
 	    AV* padav = (AV*)(AvARRAY(CvPADLIST(cv))[1]);
 	    sv = padav ? AvARRAY(padav)[o->op_targ] : Nullsv;
-	    if (!sv || (!SvREADONLY(sv) && SvREFCNT(sv) > 1))
+	    if (!sv || (!SvIMMUTABLE(sv) && SvREFCNT(sv) > 1))
 		return Nullsv;
 	}
 	else
--- ./perl.c~	Fri May 29 07:00:14 1998
+++ ./perl.c	Mon Jun  8 23:42:26 1998
@@ -168,7 +168,7 @@ perl_construct(register PerlInterpreter 
 	linestr = NEWSV(65,80);
 	sv_upgrade(linestr,SVt_PVIV);
 
-	if (!SvREADONLY(&sv_undef)) {
+	if (!SvIMMUTABLE(&sv_undef)) {
 	    SvREADONLY_on(&sv_undef);
 
 	    sv_setpv(&sv_no,No);
--- ./sv.h~	Fri May 29 07:00:22 1998
+++ ./sv.h	Mon Jun  8 23:38:06 1998
@@ -434,9 +434,20 @@ struct xpvio {
 #define SvOBJECT_on(sv)		(SvFLAGS(sv) |= SVs_OBJECT)
 #define SvOBJECT_off(sv)	(SvFLAGS(sv) &= ~SVs_OBJECT)
 
-#define SvREADONLY(sv)		(SvFLAGS(sv) & SVf_READONLY)
+    /* Should be modified via Perl API only, no direct change of
+       fields allowed.  */
+#define SvIMMUTABLE(sv)		(SvFLAGS(sv) & SVf_READONLY)
+
+    /* Should not be modified at all.  */
+#define SvREADONLY_TEST(sv)	(SvIMMUTABLE(sv) && (!SvRMAGICAL(sv) || sv_cannot_modify(sv)))
 #define SvREADONLY_on(sv)	(SvFLAGS(sv) |= SVf_READONLY)
 #define SvREADONLY_off(sv)	(SvFLAGS(sv) &= ~SVf_READONLY)
+
+    /* Request modification permission: */
+#define SvCAN_CHANGE(sv)	(!SvIMMUTABLE(sv) || (SvRMAGICAL(sv) && sv_request_modify(sv)))
+
+    /* Backward compatibility mode: assume they want to modify.  */
+#define SvREADONLY(sv)		(!SvCAN_CHANGE(sv))
 
 #define SvSCREAM(sv)		(SvFLAGS(sv) & SVp_SCREAM)
 #define SvSCREAM_on(sv)		(SvFLAGS(sv) |= SVp_SCREAM)
