From 779c5bc9b377ace543a8d55375152f3503319113 Mon Sep 17 00:00:00 2001
From: Gurusamy Sarathy <gsar@cpan.org>
Date: Wed, 21 Oct 1998 00:54:14 +0000
Subject: [PATCH] restore sanity to "constant" references

p4raw-id: //depot/perl@2029
---
 lib/constant.pm     | 14 ++++++++++++++
 op.c                | 40 +++++++++++++++++++++++++++++++++++++++-
 pod/perldiag.pod    |  8 ++++++++
 t/pragma/constant.t | 18 +++++++++++++++++-
 4 files changed, 78 insertions(+), 2 deletions(-)

diff --git a/lib/constant.pm b/lib/constant.pm
index 464e20c..5d3dd91 100644
--- a/lib/constant.pm
+++ b/lib/constant.pm
@@ -20,6 +20,18 @@ constant - Perl pragma to declare constants
 
     print "This line does nothing"		unless DEBUGGING;
 
+    # references can be declared constant
+    use constant CHASH		=> { foo => 42 };
+    use constant CARRAY		=> [ 1,2,3,4 ];
+    use constant CPSEUDOHASH	=> [ { foo => 1}, 42 ];
+    use constant CCODE		=> sub { "bite $_[0]\n" };
+
+    print CHASH->{foo};
+    print CARRAY->[$i];
+    print CPSEUDOHASH->{foo};
+    print CCODE->("me");
+    print CHASH->[10];				# compile-time error
+
 =head1 DESCRIPTION
 
 This will declare a symbol to be a constant with the given scalar
@@ -86,6 +98,8 @@ constants at compile time, allowing for way cool stuff like this.
     print   E2BIG, "\n";	# something like "Arg list too long"
     print 0+E2BIG, "\n";	# "7"
 
+Errors in dereferencing constant references are trapped at compile-time.
+
 =head1 TECHNICAL NOTE
 
 In the current implementation, scalar constants are actually
diff --git a/op.c b/op.c
index c04f082..f9c9df1 100644
--- a/op.c
+++ b/op.c
@@ -4450,8 +4450,46 @@ ck_rvconst(register OP *o)
 	char *name;
 	int iscv;
 	GV *gv;
+	SV *kidsv = kid->op_sv;
 
-	name = SvPV(kid->op_sv, PL_na);
+	/* Is it a constant from cv_const_sv()? */
+	if (SvROK(kidsv) && SvREADONLY(kidsv)) {
+	    SV *rsv = SvRV(kidsv);
+	    int svtype = SvTYPE(rsv);
+	    char *badtype = Nullch;
+
+	    switch (o->op_type) {
+	    case OP_RV2SV:
+		if (svtype > SVt_PVMG)
+		    badtype = "a SCALAR";
+		break;
+	    case OP_RV2AV:
+		if (svtype != SVt_PVAV)
+		    badtype = "an ARRAY";
+		break;
+	    case OP_RV2HV:
+		if (svtype != SVt_PVHV) {
+		    if (svtype == SVt_PVAV) {	/* pseudohash? */
+			SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
+			if (ksv && SvROK(*ksv)
+			    && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
+			{
+				break;
+			}
+		    }
+		    badtype = "a HASH";
+		}
+		break;
+	    case OP_RV2CV:
+		if (svtype != SVt_PVCV)
+		    badtype = "a CODE";
+		break;
+	    }
+	    if (badtype)
+		croak("Constant is not %s reference", badtype);
+	    return o;
+	}
+	name = SvPV(kidsv, PL_na);
 	if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
 	    char *badthing = Nullch;
 	    switch (o->op_type) {
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 8ccb16b..4e09da0 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -1002,6 +1002,14 @@ for information on I<Mastering Regular Expressions>.)
 (W) You tried to do a connect on a closed socket.  Did you forget to check
 the return value of your socket() call?  See L<perlfunc/connect>.
 
+=item Constant is not %s reference
+
+(F) A constant value (perhaps declared using the C<use constant> pragma)
+is being dereferenced, but it amounts to the wrong type of reference.  The
+message indicates the type of reference that was expected. This usually
+indicates a syntax error in dereferencing the constant value.
+See L<perlsub/"Constant Functions"> and L<constant>.
+
 =item Constant subroutine %s redefined
 
 (S) You redefined a subroutine which had previously been eligible for
diff --git a/t/pragma/constant.t b/t/pragma/constant.t
index 0b58bae..5b63dfa 100755
--- a/t/pragma/constant.t
+++ b/t/pragma/constant.t
@@ -14,7 +14,7 @@ END { print @warnings }
 
 ######################### We start with some black magic to print on failure.
 
-BEGIN { $| = 1; print "1..39\n"; }
+BEGIN { $| = 1; print "1..46\n"; }
 END {print "not ok 1\n" unless $loaded;}
 use constant;
 $loaded = 1;
@@ -139,3 +139,19 @@ test 37, @warnings &&
 
 test 38, @warnings == 0, "unexpected warning";
 test 39, $^W & 1, "Who disabled the warnings?";
+
+use constant CSCALAR	=> \"ok 40\n";
+use constant CHASH	=> { foo => "ok 41\n" };
+use constant CARRAY	=> [ undef, "ok 42\n" ];
+use constant CPHASH	=> [ { foo => 1 }, "ok 43\n" ];
+use constant CCODE	=> sub { "ok $_[0]\n" };
+
+print ${+CSCALAR};
+print CHASH->{foo};
+print CARRAY->[1];
+print CPHASH->{foo};
+eval q{ CPHASH->{bar} };
+test 44, scalar($@ =~ /^No such array/);
+print CCODE->(45);
+eval q{ CCODE->{foo} };
+test 46, scalar($@ =~ /^Constant is not a HASH/);
-- 
1.8.3.1