--- ./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 Mar 16 06:42:34 1998
+++ ./global.sym Tue Mar 17 20:36:40 1998
@@ -382,6 +382,7 @@ magic_clearsig
magic_existspack
magic_freedefelem
magic_freeregexp
+magic_freesoftlink
magic_get
magic_getarylen
magic_getdefelem
@@ -391,6 +392,7 @@ magic_getpos
magic_getsig
magic_gettaint
magic_getuvar
+magic_killsoftlinks
magic_len
magic_mutexfree
magic_nextpack
@@ -411,6 +413,7 @@ magic_setnkeys
magic_setpack
magic_setpos
magic_setsig
+magic_setsoftlink
magic_setsubstr
magic_settaint
magic_setuvar
@@ -1015,6 +1018,7 @@ sv_reftype
sv_replace
sv_report_used
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 Mar 16 06:45:24 1998
+++ ./proto.h Tue Mar 17 18:32:24 1998
@@ -212,6 +212,7 @@ int magic_clearsig _((SV* sv, MAGIC* mg)
int magic_existspack _((SV* sv, MAGIC* mg));
int magic_freedefelem _((SV* sv, MAGIC* mg));
int magic_freeregexp _((SV* sv, MAGIC* mg));
+int magic_freesoftlink _((SV* sv, MAGIC* mg));
int magic_get _((SV* sv, MAGIC* mg));
int magic_getarylen _((SV* sv, MAGIC* mg));
int magic_getdefelem _((SV* sv, MAGIC* mg));
@@ -221,6 +222,7 @@ int magic_getpos _((SV* sv, MAGIC* mg));
int magic_getsig _((SV* sv, MAGIC* mg));
int magic_gettaint _((SV* sv, MAGIC* mg));
int magic_getuvar _((SV* sv, MAGIC* mg));
+int magic_killsoftlinks _((SV* sv, MAGIC* mg));
U32 magic_len _((SV* sv, MAGIC* mg));
#ifdef USE_THREADS
int magic_mutexfree _((SV* sv, MAGIC* mg));
@@ -246,6 +248,7 @@ int magic_setnkeys _((SV* sv, MAGIC* mg)
int magic_setpack _((SV* sv, MAGIC* mg));
int magic_setpos _((SV* sv, MAGIC* mg));
int magic_setsig _((SV* sv, MAGIC* mg));
+int magic_setsoftlink _((SV* sv, MAGIC* mg));
int magic_setsubstr _((SV* sv, MAGIC* mg));
int magic_settaint _((SV* sv, MAGIC* mg));
int magic_setuvar _((SV* sv, MAGIC* mg));
@@ -537,6 +540,7 @@ char* sv_reftype _((SV* sv, int ob));
void sv_replace _((SV* sv, SV* nsv));
void sv_report_used _((void));
void sv_reset _((char* s, HV* stash));
+SV* sv_rvsoft _((SV* rv));
void sv_setpvf _((SV* sv, const char* pat, ...));
void sv_setpvf_mg _((SV* sv, const char* pat, ...));
void sv_setiv _((SV* sv, IV num));
--- ./sv.c.orig Mon Mar 16 07:04:44 1998
+++ ./sv.c Tue Mar 17 21:24:30 1998
@@ -60,6 +60,8 @@ static void sv_unglob _((SV* sv));
static void sv_check_thinkfirst _((SV *sv));
#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_check_thinkfirst(sv)
+#define SV_WEAKLY_READONLY(sv) (SvREADONLY(sv) && sv_cannot_modify(sv))
+#define SV_STRONGLY_READONLY(sv) (SvREADONLY(sv) && sv_cannot_modify_weak(sv))
#ifndef PURIFY
static void *my_safemalloc(MEM_SIZE size);
@@ -624,6 +626,46 @@ my_safemalloc(MEM_SIZE size)
#define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO))
#define del_XPVIO(p) my_safefree((char*)p)
+static int
+sv_cannot_modify(register SV *sv)
+{ /* Assume it it READONLY */
+ if (SvRMAGICAL(sv)) {
+ /* Check whether READONLY is set only for PRE_CHANGE magic. */
+ 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 SvREADONLY(sv); /* Now the real state is restored */
+ } else
+ return 1;
+}
+
+static int
+sv_cannot_modify_weak(register SV *sv)
+{ /* Assume it it READONLY */
+ if (SvRMAGICAL(sv)) {
+ /* Check whether 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 */
+ } else
+ return 1;
+}
+
bool
sv_upgrade(register SV *sv, U32 mt)
{
@@ -2302,7 +2344,7 @@ sv_usepvn_mg(register SV *sv, register c
static void
sv_check_thinkfirst(register SV *sv)
{
- if (SvREADONLY(sv)) {
+ if (SV_WEAKLY_READONLY(sv)) {
dTHR;
if (curcop != &compiling)
croak(no_modify);
@@ -2432,7 +2474,7 @@ sv_magic(register SV *sv, SV *obj, int h
{
MAGIC* mg;
- if (SvREADONLY(sv)) {
+ if (SV_STRONGLY_READONLY(sv)) {
dTHR;
if (curcop != &compiling && !strchr("gBf", how))
croak(no_modify);
@@ -2564,6 +2606,18 @@ sv_magic(register SV *sv, SV *obj, int h
case '.':
mg->mg_virtual = &vtbl_pos;
break;
+ case '>':
+ SvRMAGICAL_on(sv);
+ if (!SvREADONLY(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 */
@@ -2612,6 +2666,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)
{
@@ -3334,7 +3418,7 @@ sv_inc(register SV *sv)
if (!sv)
return;
if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv)) {
+ if (SV_WEAKLY_READONLY(sv)) {
dTHR;
if (curcop != &compiling)
croak(no_modify);
@@ -3411,7 +3495,7 @@ sv_dec(register SV *sv)
if (!sv)
return;
if (SvTHINKFIRST(sv)) {
- if (SvREADONLY(sv)) {
+ if (SV_WEAKLY_READONLY(sv)) {
dTHR;
if (curcop != &compiling)
croak(no_modify);
@@ -3506,7 +3590,7 @@ sv_2mortal(register SV *sv)
dTHR;
if (!sv)
return sv;
- if (SvREADONLY(sv) && curcop != &compiling)
+ if (SV_STRONGLY_READONLY(sv) && curcop != &compiling)
croak(no_modify);
if (++tmps_ix >= tmps_max)
sv_mortalgrow();
@@ -3882,7 +3966,7 @@ sv_pvn_force(SV *sv, STRLEN *lp)
{
char *s;
- if (SvREADONLY(sv)) {
+ if (SV_STRONGLY_READONLY(sv)) {
dTHR;
if (curcop != &compiling)
croak(no_modify);
@@ -4061,7 +4145,7 @@ sv_bless(SV *sv, HV *stash)
croak("Can't bless non-reference value");
ref = SvRV(sv);
if (SvFLAGS(ref) & (SVs_OBJECT|SVf_READONLY)) {
- if (SvREADONLY(ref))
+ if (SV_STRONGLY_READONLY(ref))
croak(no_modify);
if (SvOBJECT(ref)) {
if (SvTYPE(ref) != SVt_PVIO)
@@ -4106,7 +4190,7 @@ sv_unref(SV *sv)
SvRV(sv) = 0;
SvROK_off(sv);
- if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
+ if (SvREFCNT(rv) != 1 || SV_STRONGLY_READONLY(rv))
SvREFCNT_dec(rv);
else
sv_2mortal(rv); /* Schedule for freeing later */