develooper Front page | perl.perl5.porters | Postings from April 2003

[PATCH] allow recursive FETCHes

Thread Next
From:
Dave Mitchell
Date:
April 7, 2003 02:00
Subject:
[PATCH] allow recursive FETCHes
Message ID:
20030407100041.A1617@fdgroup.com
Executive summary:

This patch allows FETCH to access arrays and hashes which are themselves
tied without fear of crashing, by using a PVLV rather then a PVMG for the
tiedelem temp.

Problem:

av_fetch(), hv_fetch() or hv_fetch_ent() on a tied thinggy return a
temporary SV with tiedelem magic attached, so that when the SV is
accessed, its magic causes FETCH/STORE to be called. The problem is that
the API for these three functions dictates that rather than just returning
an SV*, they must return an SV** or a HE*. Currently this is achieved by
using 3 global variables which can hold an SV pointer or a static HE
struct.  This scheme collapses when FETCH itslef accesses a tied array or
hash, since the static location is overwitten with the new details.

Solution:

We make the temp with the tiedelem magic a PVLV rather than a PVMG, and
then use the extra LvTARG field to solve our problem. We introduce two
new PVLV types, 't' and 'T'. With 't', LvTARG contains an un-refcounted
pointer to itelf (ie to the SV). We then allow [ah]v_fetch to return
&LvTARG(sv), thus returning an SV**. With 'T', LvTARG points to a
temporary HE which itself points to the PVLV. When the PVLV is freed, we
return the HE to a small pool - this pool will be as big as the level of
FETCH recursion.

Caveats:

I'm not too familiar with PVLVs, so I may be using them here in ways never
intended.The main probem I faced was that stringified (or ref())
references to PVLVs are displayed as "LVALUE" rather than "SCALAR". This
slight difference at the user-level meant that I had to do a small fix to
the Storable test suite. I rather wonder whether they shouldn't always
appear as "SCALAR" instead? (But as I say, I'm not very familiar with
PVLVs).

I also found + fixed two bugs along the way:

PVLVs with SvROK on displayed as "LVALUE" - I've made them display as
"REF". Again, this was to keep Storable happy.

he_dup(), in the case of HEf_SVKEY, allocated a new HE but forgot to
allocate a HEK too. My main patch presumably exercised this code path
for the first time.

-- 
To collect all the latest movies, simply place an unprotected ftp server
on the Internet, and wait for the disk to fill....

# This is a patch for 19042.ORIG to update it to 19042.tie
# 
# To apply this patch:
# STEP 1: Chdir to the source directory.
# STEP 2: Run the 'applypatch' program with this patch file as input.
#
# If you do not have 'applypatch', it is part of the 'makepatch' package
# that you can fetch from the Comprehensive Perl Archive Network:
# http://www.perl.com/CPAN/authors/Johan_Vromans/makepatch-x.y.tar.gz
# In the above URL, 'x' should be 2 or higher.
#
# To apply this patch without the use of 'applypatch':
# STEP 1: Chdir to the source directory.
# STEP 2: Run the 'patch' program with this file as input.
#
#### End of Preamble ####

#### Patch data follows ####
diff -up '19042.ORIG/av.c' '19042.tie/av.c'
Index: ./av.c
--- ./av.c	Fri Mar 21 20:53:10 2003
+++ ./av.c	Sun Mar 30 16:59:40 2003
@@ -208,9 +208,11 @@ Perl_av_fetch(pTHX_ register AV *av, I32
             }
 
             sv = sv_newmortal();
-            mg_copy((SV*)av, sv, 0, key);
-            PL_av_fetch_sv = sv;
-            return &PL_av_fetch_sv;
+	    sv_upgrade(sv, SVt_PVLV);
+	    mg_copy((SV*)av, sv, 0, key);
+	    LvTYPE(sv) = 't';
+	    LvTARG(sv) = sv; /* fake (SV**) */
+	    return &(LvTARG(sv));
         }
     }
 
diff -up '19042.ORIG/dump.c' '19042.tie/dump.c'
Index: ./dump.c
--- ./dump.c	Fri Mar 21 20:53:10 2003
+++ ./dump.c	Sun Mar 30 22:23:13 2003
@@ -1178,8 +1178,9 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO 
 	Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
 	Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
 	Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
-	/* XXX level+1 ??? */
-	do_sv_dump(level, file, LvTARG(sv), nest+1, maxnest, dumpops, pvlim);
+	if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
+	    do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
+		    dumpops, pvlim);
 	break;
     case SVt_PVAV:
 	Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
diff -up '19042.ORIG/embed.fnc' '19042.tie/embed.fnc'
Index: ./embed.fnc
--- ./embed.fnc	Fri Mar 21 20:53:27 2003
+++ ./embed.fnc	Sat Apr  5 20:35:13 2003
@@ -1375,6 +1375,7 @@ sd	|void	|cv_dump	|CV *cv|char *title
 s	|CV*	|cv_clone2	|CV *proto|CV *outside
 #endif
 pd 	|CV*	|find_runcv	|U32 *db_seqp
+p	|void	|free_tied_hv_pool
 
 
 
diff -up '19042.ORIG/ext/Storable/t/st-dump.pl' '19042.tie/ext/Storable/t/st-dump.pl'
Index: ./ext/Storable/t/st-dump.pl
--- ./ext/Storable/t/st-dump.pl	Fri Mar 21 20:53:09 2003
+++ ./ext/Storable/t/st-dump.pl	Tue Apr  1 22:53:02 2003
@@ -39,6 +39,7 @@ use Carp;
 
 %dump = (
 	'SCALAR'	=> 'dump_scalar',
+	'LVALUE'	=> 'dump_scalar',
 	'ARRAY'		=> 'dump_array',
 	'HASH'		=> 'dump_hash',
 	'REF'		=> 'dump_ref',
diff -up '19042.ORIG/hv.c' '19042.tie/hv.c'
Index: ./hv.c
--- ./hv.c	Fri Mar 21 20:53:10 2003
+++ ./hv.c	Sun Apr  6 16:40:05 2003
@@ -89,6 +89,22 @@ S_save_hek_flags(pTHX_ const char *str, 
     return hek;
 }
 
+/* free the pool of temporary HE/HEK pairs retunrned by hv_fetch_ent
+ * for tied hashes */
+
+void
+Perl_free_tied_hv_pool(pTHX)
+{
+    HE *ohe;
+    HE *he = PL_hv_fetch_ent_mh;
+    while (he) {
+	Safefree(HeKEY_hek(he));
+	ohe = he;
+	he = HeNEXT(he);
+	del_HE(ohe);
+    }
+}
+
 #if defined(USE_ITHREADS)
 HE *
 Perl_he_dup(pTHX_ HE *e, bool shared, CLONE_PARAMS* param)
@@ -107,8 +123,12 @@ Perl_he_dup(pTHX_ HE *e, bool shared, CL
     ptr_table_store(PL_ptr_table, e, ret);
 
     HeNEXT(ret) = he_dup(HeNEXT(e),shared, param);
-    if (HeKLEN(e) == HEf_SVKEY)
+    if (HeKLEN(e) == HEf_SVKEY) {
+	char *k;
+	New(54, k, HEK_BASESIZE + sizeof(SV*), char);
+	HeKEY_hek(ret) = (HEK*)k;
 	HeKEY_sv(ret) = SvREFCNT_inc(sv_dup(HeKEY_sv(e), param));
+    }
     else if (shared)
 	HeKEY_hek(ret) = share_hek_flags(HeKEY(e), HeKLEN(e), HeHASH(e),
                                          HeKFLAGS(e));
@@ -208,11 +228,13 @@ S_hv_fetch_flags(pTHX_ HV *hv, const cha
         */
 	if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
 	    sv = sv_newmortal();
+	    sv_upgrade(sv, SVt_PVLV);
 	    mg_copy((SV*)hv, sv, key, klen);
             if (flags & HVhek_FREEKEY)
                 Safefree(key);
-	    PL_hv_fetch_sv = sv;
-	    return &PL_hv_fetch_sv;
+	    LvTYPE(sv) = 't';
+	    LvTARG(sv) = sv; /* fake (SV**) */
+	    return &(LvTARG(sv));
 	}
 #ifdef ENV_IS_CASELESS
 	else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
@@ -356,17 +378,26 @@ Perl_hv_fetch_ent(pTHX_ HV *hv, SV *keys
     if (SvRMAGICAL(hv)) {
 	if (mg_find((SV*)hv, PERL_MAGIC_tied) || SvGMAGICAL((SV*)hv)) {
 	    sv = sv_newmortal();
-	    keysv = sv_2mortal(newSVsv(keysv));
+	    keysv = newSVsv(keysv);
 	    mg_copy((SV*)hv, sv, (char*)keysv, HEf_SVKEY);
-	    if (!HeKEY_hek(&PL_hv_fetch_ent_mh)) {
+	    /* grab a fake HE/HEK pair from the pool or make a new one */
+	    entry = PL_hv_fetch_ent_mh;
+	    if (entry)
+		PL_hv_fetch_ent_mh = HeNEXT(entry);
+	    else {
 		char *k;
+		entry = new_HE();
 		New(54, k, HEK_BASESIZE + sizeof(SV*), char);
-		HeKEY_hek(&PL_hv_fetch_ent_mh) = (HEK*)k;
+		HeKEY_hek(entry) = (HEK*)k;
 	    }
-	    HeSVKEY_set(&PL_hv_fetch_ent_mh, keysv);
-	    HeVAL(&PL_hv_fetch_ent_mh) = sv;
-	    return &PL_hv_fetch_ent_mh;
-	}
+	    HeNEXT(entry) = Nullhe;
+	    HeSVKEY_set(entry, keysv);
+	    HeVAL(entry) = sv;
+	    sv_upgrade(sv, SVt_PVLV);
+	    LvTYPE(sv) = 'T';
+	    LvTARG(sv) = (SV*)entry; /* so we can free entry when freeing sv */
+	    return entry;
+ 	}
 #ifdef ENV_IS_CASELESS
 	else if (mg_find((SV*)hv, PERL_MAGIC_env)) {
 	    U32 i;
diff -up '19042.ORIG/perl.c' '19042.tie/perl.c'
Index: ./perl.c
--- ./perl.c	Fri Mar 21 20:53:10 2003
+++ ./perl.c	Sat Apr  5 20:32:49 2003
@@ -783,7 +783,7 @@ perl_destruct(pTHXx)
     if (PL_reg_curpm)
 	Safefree(PL_reg_curpm);
     Safefree(PL_reg_poscache);
-    Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
+    free_tied_hv_pool();
     Safefree(PL_op_mask);
     Safefree(PL_psig_ptr);
     Safefree(PL_psig_name);
diff -up '19042.ORIG/sv.c' '19042.tie/sv.c'
Index: ./sv.c
--- ./sv.c	Fri Mar 21 20:53:12 2003
+++ ./sv.c	Sat Apr  5 20:41:02 2003
@@ -3068,7 +3068,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv,
 				    s = "REF";
 				else
 				    s = "SCALAR";		break;
-		case SVt_PVLV:	s = "LVALUE";			break;
+		case SVt_PVLV:	s = SvROK(sv) ? "REF":"LVALUE";	break;
 		case SVt_PVAV:	s = "ARRAY";			break;
 		case SVt_PVHV:	s = "HASH";			break;
 		case SVt_PVCV:	s = "CODE";			break;
@@ -5380,7 +5380,13 @@ Perl_sv_clear(pTHX_ register SV *sv)
 	av_undef((AV*)sv);
 	break;
     case SVt_PVLV:
-	SvREFCNT_dec(LvTARG(sv));
+	if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
+	    SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
+	    HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
+	    PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
+	}
+	else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV**  */
+	    SvREFCNT_dec(LvTARG(sv));
 	goto freescalar;
     case SVt_PVGV:
 	gp_free((GV*)sv);
@@ -7770,7 +7776,7 @@ Perl_sv_reftype(pTHX_ SV *sv, int ob)
 				    return "REF";
 				else
 				    return "SCALAR";
-	case SVt_PVLV:		return "LVALUE";
+	case SVt_PVLV:		return SvROK(sv) ? "REF" : "LVALUE";
 	case SVt_PVAV:		return "ARRAY";
 	case SVt_PVHV:		return "HASH";
 	case SVt_PVCV:		return "CODE";
@@ -9979,7 +9985,12 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS
 	Perl_rvpv_dup(aTHX_ dstr, sstr, param);
 	LvTARGOFF(dstr)	= LvTARGOFF(sstr);	/* XXX sometimes holds PMOP* when DEBUGGING */
 	LvTARGLEN(dstr)	= LvTARGLEN(sstr);
-	LvTARG(dstr)	= sv_dup_inc(LvTARG(sstr), param);
+	if (LvTYPE(sstr) == 't') /* for tie: unrefcnted fake (SV**) */
+	    LvTARG(dstr) = dstr;
+	else if (LvTYPE(sstr) == 'T') /* for tie: fake HE */
+	    LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(sstr), 0, param);
+	else
+	    LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
 	LvTYPE(dstr)	= LvTYPE(sstr);
 	break;
     case SVt_PVGV:
@@ -11307,9 +11318,7 @@ perl_clone_using(PerlInterpreter *proto_
     PL_protect		= proto_perl->Tprotect;
 #endif
     PL_errors		= sv_dup_inc(proto_perl->Terrors, param);
-    PL_av_fetch_sv	= Nullsv;
-    PL_hv_fetch_sv	= Nullsv;
-    Zero(&PL_hv_fetch_ent_mh, 1, HE);			/* XXX */
+    PL_hv_fetch_ent_mh	= Nullhe;
     PL_modcount		= proto_perl->Tmodcount;
     PL_lastgotoprobe	= Nullop;
     PL_dumpindent	= proto_perl->Tdumpindent;
diff -up '19042.ORIG/sv.h' '19042.tie/sv.h'
Index: ./sv.h
--- ./sv.h	Fri Mar 21 20:53:12 2003
+++ ./sv.h	Sun Mar 30 15:36:33 2003
@@ -273,7 +273,8 @@ struct xpvlv {
     STRLEN	xlv_targoff;
     STRLEN	xlv_targlen;
     SV*		xlv_targ;
-    char	xlv_type;
+    char	xlv_type;	/* k=keys .=pos x=substr v=vec /=join/re
+				 * y=alem/helem/iter t=tie T=tied HE */
 };
 
 struct xpvgv {
diff -up '19042.ORIG/t/op/tie.t' '19042.tie/t/op/tie.t'
Index: ./t/op/tie.t
--- ./t/op/tie.t	Fri Mar 21 20:53:25 2003
+++ ./t/op/tie.t	Sun Mar 30 15:54:22 2003
@@ -295,3 +295,34 @@ tie $a, 'main';
 print $a;
 EXPECT
 Tied variable freed while still in use at - line 6.
+########
+
+#  [20020716.007] - nested FETCHES
+
+sub F1::TIEARRAY { bless [], 'F1' }
+sub F1::FETCH { 1 }
+my @f1;
+tie @f1, 'F1';
+
+sub F2::TIEARRAY { bless [2], 'F2' }
+sub F2::FETCH { my $self = shift; my $x = $f1[3]; $self }
+my @f2;
+tie @f2, 'F2';
+
+print $f2[4][0],"\n";
+
+sub F3::TIEHASH { bless [], 'F3' }
+sub F3::FETCH { 1 }
+my %f3;
+tie %f3, 'F3';
+
+sub F4::TIEHASH { bless [3], 'F4' }
+sub F4::FETCH { my $self = shift; my $x = $f3{3}; $self }
+my %f4;
+tie %f4, 'F4';
+
+print $f4{'foo'}[0],"\n";
+
+EXPECT
+2
+3
diff -up '19042.ORIG/thrdvar.h' '19042.tie/thrdvar.h'
Index: ./thrdvar.h
--- ./thrdvar.h	Fri Mar 21 20:53:13 2003
+++ ./thrdvar.h	Sun Mar 30 15:55:04 2003
@@ -140,9 +140,7 @@ PERLVARI(Tprotect,	protect_proc_t,	MEMBE
 PERLVARI(Terrors,	SV *, Nullsv)	/* outstanding queued errors */
 
 /* statics "owned" by various functions */
-PERLVAR(Tav_fetch_sv,	SV *)		/* owned by av_fetch() */
-PERLVAR(Thv_fetch_sv,	SV *)		/* owned by hv_fetch() */
-PERLVAR(Thv_fetch_ent_mh, HE)		/* owned by hv_fetch_ent() */
+PERLVAR(Thv_fetch_ent_mh, HE*)		/* owned by hv_fetch_ent() */
 
 PERLVAR(Tmodcount,	I32)		/* how much mod()ification in assignment? */
 
#### End of Patch data ####

#### ApplyPatch data follows ####
# Data version        : 1.0
# Date generated      : Sun Apr  6 16:51:32 2003
# Generated by        : makepatch 2.00_05
# Recurse directories : Yes
# Excluded files      : keywords\.h|warnings\.h|regnodes\.h|perlapi\.c|perlapi\.h|global\.sym|embedvar\.h|embed\.h|pod\/perlapi\.pod|pod\/perlintern\.pod|proto\.h
# v 'patchlevel.h' 4571 1048280033 33188
# p 'av.c' 19997 1049039980 0100644
# p 'dump.c' 46238 1049059393 0100644
# p 'embed.fnc' 50657 1049571313 0100644
# p 'ext/Storable/t/st-dump.pl' 4269 1049233982 0100644
# p 'hv.c' 61912 1049643605 0100644
# p 'perl.c' 105412 1049571169 0100644
# p 'sv.c' 290734 1049571662 0100644
# p 'sv.h' 41804 1049034993 0100644
# p 't/op/tie.t' 6076 1049036062 0100755
# p 'thrdvar.h' 8610 1049036104 0100644
#### End of ApplyPatch data ####

#### End of Patch kit [created: Sun Apr  6 16:51:32 2003] ####
#### Patch checksum: 316 10383 22599 ####
#### Checksum: 334 11065 13144 ####

Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About