From: Nicholas Clark <nick@ccl4.org>
Date: Thu, 22 Dec 2005 15:43:20 +0000 (+0000)
Subject: Regression tests for proxy subroutine glob assignment.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=bb112e5a4b9e874a52fe07cda10dbc94d64316d8;p=p5sagit%2Fp5-mst-13.2.git

Regression tests for proxy subroutine glob assignment.
Fix a bug (it turns out that a typeglob isn't SvOK())
Remove stray debugging code.

p4raw-id: //depot/perl@26448
---

diff --git a/pp_hot.c b/pp_hot.c
index c625c2c..c4cd739 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -132,7 +132,7 @@ PP(pp_sassign)
 	if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
 	    /* Is the target symbol table currently empty?  */
 	    GV *gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
-	    if (!SvOK(gv)) {
+	    if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
 		/* Good. Create a new proxy constant subroutine in the target.
 		   The gv becomes a(nother) reference to the constant.  */
 		SV *const value = SvRV(cv);
@@ -166,7 +166,6 @@ PP(pp_sassign)
 						 SvRV(cv)));
 	    SvREFCNT_dec(cv);
 	    LEAVE;
-	    PerlIO_debug("Unwrap CV\n");
 	}
 
     }
diff --git a/t/op/gv.t b/t/op/gv.t
index ad2db4a..aa9383f 100755
--- a/t/op/gv.t
+++ b/t/op/gv.t
@@ -12,7 +12,7 @@ BEGIN {
 use warnings;
 
 require './test.pl';
-plan( tests => 105 );
+plan( tests => 132 );
 
 # type coersion on assignment
 $foo = 'foo';
@@ -196,7 +196,7 @@ is($j[0], 1);
 
 {
     my $w = '';
-    $SIG{__WARN__} = sub { $w = $_[0] };
+    local $SIG{__WARN__} = sub { $w = $_[0] };
     sub abc1 ();
     local *abc1 = sub { };
     is ($w, '');
@@ -267,7 +267,9 @@ EOPROG
 # There are certain space optimisations implemented via promotion rules to
 # GVs
 
-ok(!exists $::{oonk}, "no symbols of any sort to start with");
+foreach (qw (oonk ga_shloip)) {
+    ok(!exists $::{$_}, "no symbols of any sort to start with for $_");
+}
 
 # A string in place of the typeglob is promoted to the function prototype
 $::{oonk} = "pie";
@@ -291,6 +293,92 @@ foreach my $value (3, "Perl rules", \42, qr/whatever/, [1,2,3], {1=>2},
     is ($got, $value, "Value is correctly set");
 }
 
+delete $::{oonk};
+$::{oonk} = \"Value";
+
+*{"ga_shloip"} = \&{"oonk"};
+
+is (ref $::{ga_shloip}, 'SCALAR', "Export of proxy constant as is");
+is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
+is (eval 'ga_shloip', "Value", "Constant has correct value");
+is (ref $::{ga_shloip}, 'SCALAR',
+    "Inlining of constant doesn't change represenatation");
+
+delete $::{ga_shloip};
+
+eval 'sub ga_shloip (); 1' or die $@;
+is ($::{ga_shloip}, '', "Prototype is stored as an empty string");
+
+# Check that a prototype expands.
+*{"ga_shloip"} = \&{"oonk"};
+
+is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
+is (eval 'ga_shloip', "Value", "Constant has correct value");
+is (ref \$::{ga_shloip}, 'GLOB', "Symbol table has full typeglob");
+
+
+@::zwot = ('Zwot!');
+
+# Check that assignment to an existing typeglob works
+{
+  my $w = '';
+  local $SIG{__WARN__} = sub { $w = $_[0] };
+  *{"zwot"} = \&{"oonk"};
+  is($w, '', "Should be no warning");
+}
+
+is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
+is (eval 'zwot', "Value", "Constant has correct value");
+is (ref \$::{zwot}, 'GLOB', "Symbol table has full typeglob");
+is (join ('!', @::zwot), 'Zwot!', "Existing array still in typeglob");
+
+sub spritsits () {
+    "Traditional";
+}
+
+# Check that assignment to an existing subroutine works
+{
+  my $w = '';
+  local $SIG{__WARN__} = sub { $w = $_[0] };
+  *{"spritsits"} = \&{"oonk"};
+  like($w, qr/^Constant subroutine main::spritsits redefined/,
+       "Redefining a constant sub should warn");
+}
+
+is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
+is (eval 'spritsits', "Value", "Constant has correct value");
+is (ref \$::{spritsits}, 'GLOB', "Symbol table has full typeglob");
+
+my $result;
+# Check that assignment to an existing typeglob works
+{
+  my $w = '';
+  local $SIG{__WARN__} = sub { $w = $_[0] };
+  $result = *{"plunk"} = \&{"oonk"};
+  is($w, '', "Should be no warning");
+}
+
+is (ref \$result, 'GLOB',
+    "Non void assignment should still return a typeglob");
+
+is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
+is (eval 'plunk', "Value", "Constant has correct value");
+is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
+
+my $gr = eval '\*plunk' or die;
+
+{
+  my $w = '';
+  local $SIG{__WARN__} = sub { $w = $_[0] };
+  $result = *{$gr} = \&{"oonk"};
+  like($w, qr/^Constant subroutine main::plunk redefined/,
+       "Redefining a constant sub should warn");
+}
+
+is (ref $::{oonk}, 'SCALAR', "Export doesn't affect original");
+is (eval 'plunk', "Value", "Constant has correct value");
+is (ref \$::{plunk}, 'GLOB', "Symbol table has full typeglob");
+
 format =
 .