restore sanity to "constant" references

p4raw-id: //depot/perl@2029

diff --git a/lib/constant.pm b/lib/constant.pm
index 464e20c..5d3dd91 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (executable)
--- 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/);