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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
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");
+}