From: Nicholas Clark <nick@ccl4.org>
Date: Sat, 16 Dec 2006 23:03:42 +0000 (+0000)
Subject: Add a new flag SVprv_PCS_IMPORTED (which is a pseudonym for SVf_SCREAM)
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1ccdb7301362000755034d5e6a7e73f566973104;p=p5sagit%2Fp5-mst-13.2.git

Add a new flag SVprv_PCS_IMPORTED (which is a pseudonym for SVf_SCREAM)
to note when a proxy constant subroutine is copied. This allows us to
correctly set GvIMPORTED_CV_on() if the symbol is ever turned into a
real GV.

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

diff --git a/MANIFEST b/MANIFEST
index 390e026..0a57c58 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3362,6 +3362,7 @@ t/lib/Math/BigRat/Test.pm		Math::BigRat test helper
 t/lib/mypragma.pm		An example user pragma
 t/lib/mypragma.t		Test the example user pragma
 t/lib/NoExporter.pm			Part of Test-Simple
+t/lib/proxy_constant_subs.t	Test that Proxy Constant Subs behave correctly
 t/lib/sample-tests/bailout		Test data for Test::Harness
 t/lib/sample-tests/bignum		Test data for Test::Harness
 t/lib/sample-tests/bignum_many		Test data for Test::Harness
diff --git a/dump.c b/dump.c
index 4622fb9..eefa477 100644
--- a/dump.c
+++ b/dump.c
@@ -1385,8 +1385,12 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
     if (flags & SVp_IOK)	sv_catpv(d, "pIOK,");
     if (flags & SVp_NOK)	sv_catpv(d, "pNOK,");
     if (flags & SVp_POK)	sv_catpv(d, "pPOK,");
-    if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv))
+    if (flags & SVp_SCREAM && type != SVt_PVHV && !isGV_with_GP(sv)) {
+	if (SvPCS_IMPORTED(sv))
+				sv_catpv(d, "PCS_IMPORTED,");
+	else
 				sv_catpv(d, "SCREAM,");
+    }
 
     switch (type) {
     case SVt_PVCV:
diff --git a/gv.c b/gv.c
index fc22aeb..394e684 100644
--- a/gv.c
+++ b/gv.c
@@ -191,6 +191,7 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
     const bool doproto = old_type > SVt_NULL;
     const char * const proto = (doproto && SvPOK(gv)) ? SvPVX_const(gv) : NULL;
     SV *const has_constant = doproto && SvROK(gv) ? SvRV(gv) : NULL;
+    const U32 exported_constant = has_constant ? SvPCS_IMPORTED(gv) : 0;
 
     assert (!(proto && has_constant));
 
@@ -239,6 +240,11 @@ Perl_gv_init(pTHX_ GV *gv, HV *stash, const char *name, STRLEN len, int multi)
 	if (has_constant) {
 	    /* newCONSTSUB takes ownership of the reference from us.  */
 	    GvCV(gv) = newCONSTSUB(stash, name, has_constant);
+	    /* If this reference was a copy of another, then the subroutine
+	       must have been "imported", by a Perl space assignment to a GV
+	       from a reference to CV.  */
+	    if (exported_constant)
+		GvIMPORTED_CV_on(gv);
 	} else {
 	    /* XXX unsafe for threads if eval_owner isn't held */
 	    (void) start_subparse(0,0);	/* Create empty CV in compcv. */
diff --git a/pp_hot.c b/pp_hot.c
index 9fe7c70..4038629 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -150,7 +150,7 @@ PP(pp_sassign)
 		SV *const value = SvRV(cv);
 
 		SvUPGRADE((SV *)gv, SVt_RV);
-		SvROK_on(gv);
+		SvPCS_IMPORTED_on(gv);
 		SvRV_set(gv, value);
 		SvREFCNT_inc_simple_void(value);
 		SETs(right);
diff --git a/sv.h b/sv.h
index a8e7a2e..9265197 100644
--- a/sv.h
+++ b/sv.h
@@ -294,6 +294,10 @@ perform the upgrade if necessary.  See C<svtype>.
 #define SVp_SCREAM	0x00008000  /* has been studied? */
 #define SVphv_CLONEABLE	SVp_SCREAM  /* PVHV (stashes) clone its objects */
 #define SVpgv_GP	SVp_SCREAM  /* GV has a valid GP */
+#define SVprv_PCS_IMPORTED  SVp_SCREAM  /* RV is a proxy for a constant
+				       subroutine in another package. Set the
+				       CvIMPORTED_CV_ON() if it needs to be
+				       expanded to a real GV */
 
 #define SVs_PADSTALE	0x00010000  /* lexical has gone out of scope */
 #define SVpad_STATE	0x00010000  /* pad name is a "state" var */
@@ -1013,6 +1017,11 @@ the scalar's value cannot change unless written to.
 #define SvWEAKREF_on(sv)	(SvFLAGS(sv) |=  (SVf_ROK|SVprv_WEAKREF))
 #define SvWEAKREF_off(sv)	(SvFLAGS(sv) &= ~(SVf_ROK|SVprv_WEAKREF))
 
+#define SvPCS_IMPORTED(sv)	((SvFLAGS(sv) & (SVf_ROK|SVprv_PCS_IMPORTED)) \
+				 == (SVf_ROK|SVprv_PCS_IMPORTED))
+#define SvPCS_IMPORTED_on(sv)	(SvFLAGS(sv) |=  (SVf_ROK|SVprv_PCS_IMPORTED))
+#define SvPCS_IMPORTED_off(sv)	(SvFLAGS(sv) &= ~(SVf_ROK|SVprv_PCS_IMPORTED))
+
 #define SvTHINKFIRST(sv)	(SvFLAGS(sv) & SVf_THINKFIRST)
 
 #define SvPADSTALE(sv)		(SvFLAGS(sv) & SVs_PADSTALE)
diff --git a/t/lib/proxy_constant_subs.t b/t/lib/proxy_constant_subs.t
new file mode 100644
index 0000000..4af73d3
--- /dev/null
+++ b/t/lib/proxy_constant_subs.t
@@ -0,0 +1,41 @@
+my @symbols;
+BEGIN {
+    chdir 't';
+    @INC = '../lib';
+    require Config;
+    if (($Config::Config{'extensions'} !~ /\bB\b/) ){
+        print "1..0 # Skip -- Perl configured without B module\n";
+        exit 0;
+    }
+    if ($Config::Config{'extensions'} !~ /\bPOSIX\b/) {
+        print "1..0 # Skip -- Perl configured without POSIX\n";
+        exit 0;
+    }
+    # errno is a real subroutine, and acts as control
+    # SEEK_SET is a proxy constant subroutine.
+    @symbols = qw(errno SEEK_SET);
+}
+
+use strict;
+use warnings;
+use Test::More tests => 4 * @symbols;
+use B qw(svref_2object GVf_IMPORTED_CV);
+use POSIX @symbols;
+
+# GVf_IMPORTED_CV should not be set on the original, but should be set on the
+# imported GV.
+
+foreach my $symbol (@symbols) {
+    my ($ps, $ms);
+    {
+	no strict 'refs';
+	$ps = svref_2object(\*{"POSIX::$symbol"});
+	$ms = svref_2object(\*{"::$symbol"});
+    }
+    isa_ok($ps, 'B::GV');
+    is($ps->GvFLAGS() & GVf_IMPORTED_CV, 0,
+       "GVf_IMPORTED_CV not set on original");
+    isa_ok($ms, 'B::GV');
+    is($ms->GvFLAGS() & GVf_IMPORTED_CV, GVf_IMPORTED_CV,
+       "GVf_IMPORTED_CV set on imported GV");
+}