develooper Front page | perl.perl5.porters | Postings from February 2000

[PATCH 5.5.660] better avhv patch

Thread Previous | Thread Next
From:
John Tobey
Date:
February 28, 2000 19:13
Subject:
[PATCH 5.5.660] better avhv patch
Message ID:
m12Pd6J-000FPmC@feynman.localnet
Here is a new version of the patch that avoids op.c and instead walks
the op tree at run time in pp_aassign.  As per Sarathy's instructions,
this code is careful about dereferencing OP pointers and does not
change the avhv public interface.

Your extra tests pass (with a minor fix in #28).  They are included in
the patch.

Thanks
-John

-- 
John Tobey, late nite hacker <jtobey@john-edwin-tobey.org>
\\\                                                               ///
]]]             With enough bugs, all eyes are shallow.           [[[
///                                                               \\\

diff -ur perl5.5.660/av.c perl5.5.660.john/av.c
--- perl5.5.660/av.c	Tue Feb 22 23:38:14 2000
+++ perl5.5.660.john/av.c	Mon Feb 28 21:42:07 2000
@@ -805,6 +805,20 @@
     return index;    
 }
 
+STATIC I32
+S_avhv_index(pTHX_ AV *av, SV *keysv, U32 hash)
+{
+    HV *keys;
+    HE *he;
+    STRLEN n_a;
+
+    keys = avhv_keys(av);
+    he = hv_fetch_ent(keys, keysv, FALSE, hash);
+    if (!he)
+        Perl_croak(aTHX_ "No such pseudo-hash field \"%s\"", SvPV(keysv,n_a));
+    return avhv_index_sv(HeVAL(he));
+}
+
 HV*
 Perl_avhv_keys(pTHX_ AV *av)
 {
@@ -824,17 +838,15 @@
 }
 
 SV**
+Perl_avhv_store_ent(pTHX_ AV *av, SV *keysv, SV *val, U32 hash)
+{
+    return av_store(av, avhv_index(av, keysv, hash), val);
+}
+
+SV**
 Perl_avhv_fetch_ent(pTHX_ AV *av, SV *keysv, I32 lval, U32 hash)
 {
-    SV **indsvp;
-    HV *keys = avhv_keys(av);
-    HE *he;
-    STRLEN n_a;
-   
-    he = hv_fetch_ent(keys, keysv, FALSE, hash);
-    if (!he)
-        Perl_croak(aTHX_ "No such pseudo-hash field \"%s\"", SvPV(keysv,n_a));
-    return av_fetch(av, avhv_index_sv(HeVAL(he)), lval);
+    return av_fetch(av, avhv_index(av, keysv, hash), lval);
 }
 
 SV *
diff -ur perl5.5.660/embed.pl perl5.5.660.john/embed.pl
--- perl5.5.660/embed.pl	Tue Feb 22 23:38:15 2000
+++ perl5.5.660.john/embed.pl	Mon Feb 28 21:42:07 2000
@@ -1352,6 +1352,7 @@
 Ap	|SV*	|avhv_delete_ent|AV *ar|SV* keysv|I32 flags|U32 hash
 Ap	|bool	|avhv_exists_ent|AV *ar|SV* keysv|U32 hash
 Ap	|SV**	|avhv_fetch_ent	|AV *ar|SV* keysv|I32 lval|U32 hash
+Ap	|SV**	|avhv_store_ent	|AV *ar|SV* keysv|SV* val|U32 hash
 Ap	|HE*	|avhv_iternext	|AV *ar
 Ap	|SV*	|avhv_iterval	|AV *ar|HE* entry
 Ap	|HV*	|avhv_keys	|AV *ar
@@ -2153,6 +2154,7 @@
 
 #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT)
 s	|I32	|avhv_index_sv	|SV* sv
+s	|I32	|avhv_index	|AV* av|SV* sv|U32 hash
 #endif
 
 #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
diff -ur perl5.5.660/pp_hot.c perl5.5.660.john/pp_hot.c
--- perl5.5.660/pp_hot.c	Tue Feb 22 23:38:18 2000
+++ perl5.5.660.john/pp_hot.c	Mon Feb 28 21:42:07 2000
@@ -639,6 +639,7 @@
     HV *hash;
     I32 i;
     int magic;
+    OP *leftop;
 
     PL_delaymagic = DM_DELAY;		/* catch simultaneous items */
 
@@ -661,34 +662,68 @@
     lelem = firstlelem;
     ary = Null(AV*);
     hash = Null(HV*);
+
+    if (!((leftop = ((BINOP*)PL_op)->op_last) &&
+	  leftop->op_type == OP_NULL &&
+	  leftop->op_targ == OP_LIST &&
+	  (leftop = ((LISTOP*)leftop)->op_first) &&
+	  leftop->op_type == OP_PUSHMARK))
+	leftop = Nullop;
+
     while (lelem <= lastlelem) {
 	TAINT_NOT;		/* Each item stands on its own, taintwise. */
 	sv = *lelem++;
+	if (leftop)
+	    leftop = leftop->op_sibling;
 	switch (SvTYPE(sv)) {
 	case SVt_PVAV:
 	    ary = (AV*)sv;
 	    magic = SvMAGICAL(ary) != 0;
-	    
-	    av_clear(ary);
-	    av_extend(ary, lastrelem - relem);
-	    i = 0;
-	    while (relem <= lastrelem) {	/* gobble up all the rest */
-		SV **didstore;
-		sv = NEWSV(28,0);
-		assert(*relem);
-		sv_setsv(sv,*relem);
-		*(relem++) = sv;
-		didstore = av_store(ary,i++,sv);
-		if (magic) {
-		    if (SvSMAGICAL(sv))
-			mg_set(sv);
-		    if (!didstore)
-			sv_2mortal(sv);
+	    if (leftop && leftop->op_type == OP_RV2HV) { /* pseudohash */
+		if (av_len(ary) > 0)
+		    av_fill(ary, 0);	/* clear all but the fields hash */
+		if (lastrelem >= relem) {
+		    while (relem < lastrelem) {	/* gobble up all the rest */
+			SV *tmpstr;
+			assert(relem[0]);
+			assert(relem[1]);
+			/* Avoid a memory leak when avhv_store_ent dies. */
+			tmpstr = sv_newmortal();
+			sv_setsv(tmpstr,relem[1]);	/* value */
+			relem[1] = tmpstr;
+			if (avhv_store_ent(ary,relem[0],tmpstr,0))
+			    SvREFCNT_inc(tmpstr);
+			if (magic && SvSMAGICAL(tmpstr))
+			    mg_set(tmpstr);
+			relem += 2;
+			TAINT_NOT;
+		    }
+		}
+		if (relem == lastrelem)
+		    goto oddball;
+	    }
+	    else {					/* array */
+		av_clear(ary);
+		av_extend(ary, lastrelem - relem);
+		i = 0;
+		while (relem <= lastrelem) {	/* gobble up all the rest */
+		    SV **didstore;
+		    sv = NEWSV(28,0);
+		    assert(*relem);
+		    sv_setsv(sv,*relem);
+		    *(relem++) = sv;
+		    didstore = av_store(ary,i++,sv);
+		    if (magic) {
+			if (SvSMAGICAL(sv))
+			    mg_set(sv);
+			if (!didstore)
+			    sv_2mortal(sv);
+		    }
+		    TAINT_NOT;
 		}
-		TAINT_NOT;
 	    }
 	    break;
-	case SVt_PVHV: {
+	case SVt_PVHV: {				/* normal hash */
 		SV *tmpstr;
 
 		hash = (HV*)sv;
@@ -715,6 +750,7 @@
 		    TAINT_NOT;
 		}
 		if (relem == lastrelem) {
+		oddball:
 		    if (*relem) {
 			HE *didstore;
 			if (ckWARN(WARN_MISC)) {
@@ -726,13 +762,23 @@
 			    else
 				Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
 			}
-			tmpstr = NEWSV(29,0);
-			didstore = hv_store_ent(hash,*relem,tmpstr,0);
-			if (magic) {
-			    if (SvSMAGICAL(tmpstr))
+			if (leftop && leftop->op_type == OP_RV2HV) {
+			    /* pseudohash */
+			    tmpstr = sv_newmortal();
+			    if (avhv_store_ent(ary,*relem,tmpstr,0))
+				SvREFCNT_inc(tmpstr);
+			    if (magic && SvSMAGICAL(tmpstr))
 				mg_set(tmpstr);
-			    if (!didstore)
-				sv_2mortal(tmpstr);
+			}
+			else {
+			    tmpstr = NEWSV(29,0);
+			    didstore = hv_store_ent(hash,*relem,tmpstr,0);
+			    if (magic) {
+				if (SvSMAGICAL(tmpstr))
+				    mg_set(tmpstr);
+				if (!didstore)
+				    sv_2mortal(tmpstr);
+			    }
 			}
 			TAINT_NOT;
 		    }
diff -ur perl5.5.660/t/op/avhv.t perl5.5.660.john/t/op/avhv.t
--- perl5.5.660/t/op/avhv.t	Thu Jan 13 01:42:53 2000
+++ perl5.5.660.john/t/op/avhv.t	Mon Feb 28 21:42:07 2000
@@ -1,5 +1,5 @@
 #!./perl
-      
+
 BEGIN {
     chdir 't' if -d 't';
     unshift @INC, '../lib';
@@ -17,7 +17,7 @@
 
 package main;
 
-print "1..20\n";
+print "1..28\n";
 
 $sch = {
     'abc' => 1,
@@ -90,7 +90,7 @@
 
 $avhv = [];
 eval { $a = %$avhv };
-print "not " unless $@ and $@ =~ /^Can't coerce array into hash/;
+print "not " unless $@ and $@ =~ /^Can't coerce array into hash/;  #'
 print "ok 9\n";
 
 $avhv = [{foo=>1, bar=>2}];
@@ -139,3 +139,40 @@
 
 print "not " unless "$avhv->{bar}" eq "yyy";
 print "ok 20\n";
+
+# hash assignment
+%$avhv = ();
+print "not " unless ref($avhv->[0]) eq 'HASH';
+print "ok 21\n";
+
+%hv = %$avhv;
+print "not " if grep defined, values %hv;
+print "ok 22\n";
+print "not " if grep ref, keys %hv;
+print "ok 23\n";
+
+%$avhv = (foo => 29, pants => 2, bar => 0);
+print "not " unless "@$avhv[1..3]" eq '29 0 2';
+print "ok 24\n";
+
+my $extra;
+my @extra;
+($extra, %$avhv) = ("moo", foo => 42, pants => 53, bar => "HIKE!");
+print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and $extra eq 'moo';
+print "ok 25\n";
+
+%$avhv = ();
+(%$avhv, $extra) = (foo => 42, pants => 53, bar => "HIKE!");
+print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and !defined $extra;
+print "ok 26\n";
+
+@extra = qw(whatever and stuff);
+%$avhv = ();
+(%$avhv, @extra) = (foo => 42, pants => 53, bar => "HIKE!");
+print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and @extra == 0;
+print "ok 27\n";
+
+%$avhv = ();
+(@extra, %$avhv) = (foo => 42, pants => 53, bar => "HIKE!");
+print "not " unless ref $avhv->[0] eq 'HASH' and @extra == 6;
+print "ok 28\n";
diff -ur perl5.5.660/t/op/hashwarn.t perl5.5.660.john/t/op/hashwarn.t
--- perl5.5.660/t/op/hashwarn.t	Tue Jul 20 13:18:14 1999
+++ perl5.5.660.john/t/op/hashwarn.t	Mon Feb 28 21:42:07 2000
@@ -14,7 +14,7 @@
     # ...and save 'em as we go
     $SIG{'__WARN__'} = sub { push @warnings, @_ };
     $| = 1;
-    print "1..7\n";
+    print "1..9\n";
 }
 
 END { print "not ok\n# Uncaught warnings:\n@warnings\n" if @warnings }
@@ -66,6 +66,13 @@
     %hash = sub { print "ok" };
     test_warning 6, shift @warnings, $odd_msg;
 
+    my $avhv = [{x=>1,y=>2}];
+    %$avhv = (x=>13,'y');
+    test_warning 7, shift @warnings, $odd_msg;
+
+    %$avhv = 'x';
+    test_warning 8, shift @warnings, $odd_msg;
+
     $_ = { 1..10 };
-    test 7, ! @warnings, "Unexpected warning";
+    test 9, ! @warnings, "Unexpected warning";
 }

Thread Previous | 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