Re: [PATCH] GLOB to LVALUE assignment fix

Message-Id:  <20040217163216.GA6805@ethan>

Make PVLV a superset of PVGV, so that $lvalue = *FOO works

p4raw-id: //depot/perl@22315

8 files changed, 72 insertions, 32 deletions

diff --git a/dump.c b/dump.c
index 5f56689bc8..17e132b0a9 100644
--- a/dump.c
+++ b/dump.c
@@ -1034,7 +1034,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 	if (HvHASKFLAGS(sv))	sv_catpv(d, "HASKFLAGS,");
 	if (HvREHASH(sv))	sv_catpv(d, "REHASH,");
 	break;
-    case SVt_PVGV:
+    case SVt_PVGV: case SVt_PVLV:
 	if (GvINTRO(sv))	sv_catpv(d, "INTRO,");
 	if (GvMULTI(sv))	sv_catpv(d, "MULTI,");
 	if (GvUNIQUE(sv))       sv_catpv(d, "UNIQUE,");
@@ -1170,7 +1170,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 	SvREFCNT_dec(d);
 	return;
     }
-    if (type <= SVt_PVLV) {
+    if (type <= SVt_PVLV && type != SVt_PVGV) {
 	if (SvPVX(sv)) {
 	    Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(SvPVX(sv)));
 	    if (SvOOK(sv))
@@ -1192,15 +1192,6 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 	    do_hv_dump(level, file, "  STASH", SvSTASH(sv));
     }
     switch (type) {
-    case SVt_PVLV:
-	Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
-	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)));
-	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)));
 	if (AvARRAY(sv) != AvALLOC(sv)) {
@@ -1357,7 +1348,16 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 	if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
 	    do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
 	break;
-    case SVt_PVGV:
+    case SVt_PVGV: case SVt_PVLV:
+    if (type == SVt_PVLV) {
+        Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
+        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)));
+        if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
+            do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
+                dumpops, pvlim);
+    }
 	Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", GvNAME(sv));
 	Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
 	do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
diff --git a/ext/B/B.pm b/ext/B/B.pm
index c4d0d45d3e..5659da39ce 100644
--- a/ext/B/B.pm
+++ b/ext/B/B.pm
@@ -36,7 +36,7 @@ use strict;
 @B::PVIV::ISA = qw(B::PV B::IV);
 @B::PVNV::ISA = qw(B::PV B::NV);
 @B::PVMG::ISA = 'B::PVNV';
-@B::PVLV::ISA = 'B::PVMG';
+@B::PVLV::ISA = 'B::GV';
 @B::BM::ISA = 'B::PVMG';
 @B::AV::ISA = 'B::PVMG';
 @B::GV::ISA = 'B::PVMG';
@@ -547,11 +547,11 @@ inheritance hierarchy mimics the underlying C "inheritance":
                            |
                         B::PVMG
                            |
-         +------+-----+----+------+-----+-----+
-         |      |     |    |      |     |     |
-      B::PVLV B::BM B::AV B::GV B::HV B::CV B::IO
-                                        |
-                                        |
+                +-----+----+------+-----+-----+
+                |     |    |      |     |     |
+              B::BM B::AV B::GV B::HV B::CV B::IO
+                           |            |
+                        B::PVLV         |
                                       B::FM
 
 
diff --git a/ext/B/B.xs b/ext/B/B.xs
index 3aac784534..f428fbdde3 100644
--- a/ext/B/B.xs
+++ b/ext/B/B.xs
@@ -29,11 +29,11 @@ static char *svclassnames[] = {
     "B::PVNV",
     "B::PVMG",
     "B::BM",
+    "B::GV",
     "B::PVLV",
     "B::AV",
     "B::HV",
     "B::CV",
-    "B::GV",
     "B::FM",
     "B::IO",
 };
diff --git a/pp.c b/pp.c
index f06e71f10c..3426ca2e73 100644
--- a/pp.c
+++ b/pp.c
@@ -830,7 +830,7 @@ PP(pp_undef)
 PP(pp_predec)
 {
     dSP;
-    if (SvTYPE(TOPs) > SVt_PVLV)
+    if (SvTYPE(TOPs) == SVt_PVGV || SvTYPE(TOPs) > SVt_PVLV)
 	DIE(aTHX_ PL_no_modify);
     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
         && SvIVX(TOPs) != IV_MIN)
@@ -847,7 +847,7 @@ PP(pp_predec)
 PP(pp_postinc)
 {
     dSP; dTARGET;
-    if (SvTYPE(TOPs) > SVt_PVLV)
+    if (SvTYPE(TOPs) == SVt_PVGV || SvTYPE(TOPs) > SVt_PVLV)
 	DIE(aTHX_ PL_no_modify);
     sv_setsv(TARG, TOPs);
     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
@@ -869,7 +869,7 @@ PP(pp_postinc)
 PP(pp_postdec)
 {
     dSP; dTARGET;
-    if (SvTYPE(TOPs) > SVt_PVLV)
+    if (SvTYPE(TOPs) == SVt_PVGV || SvTYPE(TOPs) > SVt_PVLV)
 	DIE(aTHX_ PL_no_modify);
     sv_setsv(TARG, TOPs);
     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
diff --git a/pp_hot.c b/pp_hot.c
index ccfbf4181c..48ac968aaf 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -295,7 +295,7 @@ PP(pp_eq)
 PP(pp_preinc)
 {
     dSP;
-    if (SvTYPE(TOPs) > SVt_PVLV)
+    if (SvTYPE(TOPs) == SVt_PVGV || SvTYPE(TOPs) > SVt_PVLV)
 	DIE(aTHX_ PL_no_modify);
     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
         && SvIVX(TOPs) != IV_MAX)
@@ -1980,8 +1980,8 @@ PP(pp_subst)
 	!is_cow &&
 #endif
 	(SvREADONLY(TARG)
-	|| (SvTYPE(TARG) > SVt_PVLV
-	    && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
+	|| ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
+	     && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
 	DIE(aTHX_ PL_no_modify);
     PUTBACK;
 
diff --git a/sv.c b/sv.c
index 98f19c57e7..3d8ad42c82 100644
--- a/sv.c
+++ b/sv.c
@@ -1455,6 +1455,11 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
 	LvTARGLEN(sv)	= 0;
 	LvTARG(sv)	= 0;
 	LvTYPE(sv)	= 0;
+    GvGP(sv)    = 0;
+    GvNAME(sv)  = 0;
+    GvNAMELEN(sv)   = 0;
+    GvSTASH(sv) = 0;
+    GvFLAGS(sv) = 0;
 	break;
     case SVt_PVAV:
 	SvANY(sv) = new_XPVAV();
@@ -3783,7 +3788,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
 	    if (dtype != SVt_PVGV) {
 		char *name = GvNAME(sstr);
 		STRLEN len = GvNAMELEN(sstr);
-		sv_upgrade(dstr, SVt_PVGV);
+        if (dtype != SVt_PVLV)  /* don't upgrade SVt_PVLV: it can hold a glob */
+            sv_upgrade(dstr, SVt_PVGV);
 		sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
 		GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
 		GvNAME(dstr) = savepvn(name, len);
diff --git a/sv.h b/sv.h
index c694daba82..1dbf6ea1b7 100644
--- a/sv.h
+++ b/sv.h
@@ -53,11 +53,11 @@ typedef enum {
 	SVt_PVNV,	/* 6 */
 	SVt_PVMG,	/* 7 */
 	SVt_PVBM,	/* 8 */
-	SVt_PVLV,	/* 9 */
-	SVt_PVAV,	/* 10 */
-	SVt_PVHV,	/* 11 */
-	SVt_PVCV,	/* 12 */
-	SVt_PVGV,	/* 13 */
+	SVt_PVGV,	/* 9 */
+	SVt_PVLV,	/* 10 */
+	SVt_PVAV,	/* 11 */
+	SVt_PVHV,	/* 12 */
+	SVt_PVCV,	/* 13 */
 	SVt_PVFM,	/* 14 */
 	SVt_PVIO	/* 15 */
 } svtype;
@@ -272,6 +272,13 @@ struct xpvlv {
     MAGIC*	xmg_magic;	/* linked list of magicalness */
     HV*		xmg_stash;	/* class package */
 
+    /* a full glob fits into this */
+    GP*		xgv_gp;
+    char*	xgv_name;
+    STRLEN	xgv_namelen;
+    HV*		xgv_stash;
+    U8		xgv_flags;
+
     STRLEN	xlv_targoff;
     STRLEN	xlv_targlen;
     SV*		xlv_targ;
diff --git a/t/op/gv.t b/t/op/gv.t
index 9b347d3e20..5b1237a9c8 100755
--- a/t/op/gv.t
+++ b/t/op/gv.t
@@ -11,7 +11,7 @@ BEGIN {
 
 use warnings;
 
-print "1..48\n";
+print "1..52\n";
 
 # type coersion on assignment
 $foo = 'foo';
@@ -217,6 +217,33 @@ print $j[0] == 1 ? "ok 43\n" : "not ok 43\n";
     print $x;
 }
 
+{
+    # test the assignment of a GLOB to an LVALUE
+    my $e = '';
+    local $SIG{__DIE__} = sub { $e = $_[0] };
+    my $v;
+    sub f { $_[0] = 0; $_[0] = "a"; $_[0] = *DATA }
+    f($v);
+    print $v eq '*main::DATA' ? "ok 49\n" : "not ok 49\n# $e";
+    my $x = <$v>;
+    print $x || "not ok 50\n";
+}
+
+{   
+    # GLOB assignment to tied element
+    local $SIG{__DIE__} = sub { $e = $_[0] };
+    sub T::TIEARRAY { bless [] => "T" }
+    sub T::STORE    { $_[0]->[ $_[1] ] = $_[2] }
+    sub T::FETCH    { $_[0]->[ $_[1] ] }
+    tie my @ary => "T";
+    $ary[0] = *DATA;
+    print $ary[0] eq '*main::DATA' ? "ok 51\n" : "not ok 51\n# $e";
+    my $x = readline $ary[0];
+    print $x || "not ok 52\n";
+}
+
 __END__
 ok 44
 ok 48
+ok 50
+ok 52